问题描述
我正在开发一种工具，在该工具中特定表格被过滤，输出到另一个工作表，然后提交到 word。过滤后的部分也给出并提交给word。这是介绍。
Target Now：通过将数字分成两部分来指定过滤数据，并将一部分提交到附加列。
过滤器代码：
Sub Unique_Values_Worksheet_Variables()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet,rng As Range
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFiltercopy,_
copyToRange:=dws.Range("A:A"),_
Unique:=True
dws.Columns("A:A").EntireColumn.AutoFit
Set rng = dws.Range("A1",dws.Cells(Rows.Count,1).End(xlUp))
rng.Borders(xlDiagonalDown).Linestyle = xlNone
With rng.Borders()
.Linestyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ActiveWindow.displayGridlines = False
End Sub
结果是：
（感谢本论坛的合作）
现在我想按数字拆分 A 列。这意味着最小数字长度为 4 个数字（最后 4 个数字）的每一行都应被拆分并转移到紧贴列。如果有最后 4 位数字的长度要提交到 B 列，则“其余”应保留在 A 列中。
示例：
- Cell(2,A) = 是空白的'不需要
- Cell(3,A) = 1 '不需要，它不再显示
- Cell(6,A) = 40218 ' 这将被分成 4 个剩余的列 A、0218转移到B列
事实是，最后 4 位数字总是要提交到下一列，如果有 4 位数字，则 这4位数字前面的“rest”应保留在A列。
解决方法
按字符数拆分
- 您可能希望在拆分后应用格式。
Option Explicit
Sub Unique_Values_Worksheet_Variables()
Const Chars As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFilterCopy,_
CopyToRange:=dws.Range("A:A"),_
Unique:=True
dws.Columns("A:A").EntireColumn.AutoFit
Dim rng As Range:
Set rng = dws.Range("A1",dws.Cells(dws.Rows.Count,1).End(xlUp))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
With rng.Borders()
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1),Chars
ActiveWindow.DisplayGridlines = False
End Sub
Sub splitByChars( _
ByRef rg As Range,_
ByVal Chars As Long)
Dim Data As Variant: Data = rg.Value
Dim rCount As Long: rCount = UBound(Data,1)
Dim cCount As Long: cCount = 1
Dim cSize As Long
Dim r As Long,c As Long
Dim iLen As Long,fLen As Long,rLen As Long
Dim iString As String,rString As String
For r = 1 To rCount
iString = CStr(Data(r,1))
iLen = Len(iString)
If iLen >= Chars Then
fLen = iLen Mod Chars
Data(r,1) = Left(iString,fLen)
rLen = iLen - fLen
cSize = rLen / Chars + 1
rString = Mid(iString,fLen + 1,rLen)
If cSize > cCount Then
cCount = cSize
ReDim Preserve Data(1 To rCount,1 To cSize)
End If
For c = 2 To cSize
Data(r,c) = Mid(rString,(c - 2) * Chars + 1,Chars)
Debug.Print r,c,Data(r,c)
Next c
End If
Next r
With rg.Resize(,cCount)
.NumberFormat = "@"
.Value = Data
End With
End Sub
感谢@VBasic2008
我现在进一步开发了以下内容
- 将名称“Produkthierachie”更改为“Produktgruppe”
- 在活动工作表上输入 Cell.Value(1,2) 到“Serie”
- 按行将 B 列框起来
- 删除中间的所有行
我现在想要实现的是将 B 列“Serie”中的所有项目加入一个由逗号分隔的单元格，如果该系列拥有相同的 Produktgruppe“产品组”。
这应该可以用 If 分支或 do 循环还是？
Sub Unique_Values_Worksheet_Variables()
Const Chars As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("export")
Dim dws As Worksheet:
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sws.Range("C:C").AdvancedFilter _
Action:=xlFilterCopy,_
Unique:=True
dws.Columns("A:B").EntireColumn.AutoFit
Dim rng As Range:
Set rng = dws.Range("A1:B1",1).End(xlUp))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.HorizontalAlignment = xlCenter
With rng.Borders()
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Cells(1,1).Value = "Produktgruppe"
Cells(1,2).Value = "Serie"
splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1),Chars
ActiveWindow.DisplayGridlines = False
End Sub
Sub splitByChars( _
ByRef rg As Range,c)
Next c
Else
Data(r,1) = ""
End If
Next r
With rg.Resize(,cCount)
.NumberFormat = "@"
.Value = Data
End With
On Error Resume Next
With rg
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub