如何得到这个结果？
How to get to this result?
我想在 D:F
中实现以下结果
4 位数字分配给 D 列中的正确数字，F 列中的每个百分比分配给 E 列中的正确值。
我使用了以下代码作为拆分部分（fe. 40218 在 D 列中变为 40，在 E 列中变为 0218），当然得到了本论坛的大量帮助。该代码是由前面的子程序调用的子程序。我不能再结合使用两者，因为我已经通过其高级过滤器更改了前面的代码（首先它仅在您可以在 H 列中看到的输出上进行过滤，我对其进行了调整，因此 I 和 J 列也提交给了输出范围）。无论如何，如果我使用 H:J 作为起点，那对我来说很好。这只是为了快速解释为什么 sub splitByChars 包含参数 ByRef & ByVal
所以范围 H:J 是新的起点零。
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
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
此代码的问题是 D 中缺少位数少于 2 的所有值。Chars were declared in the precending code =4 因为在列 E 中，数字始终为 4 位数 length
所以问题 1 出现了：并非所有 D 中的值都显示出来，因为并非所有值都在列 H
中的至少一位数字后面有 4 位数字
出现的第二个问题是 D 中的偶数是
unique 通过它们在 I 列中的值显示差异，所以我不能
将所有值相加，例如从 4 到 4，因为百分比来自
示例 40218 是 15% 而不是像其他 50%
分配给 4.
这对我来说真的很重要，你们都知道我真的不想浪费你们的时间来寻找一个解决所有问题的代码。我是初学者，我理解的越来越多，但这已经超出了我对 VBA.
逻辑和知识水平的理解和技能。
如果您认为这很容易，我非常感谢您的帮助。如果你说，“伙计，这是不可能的”也很好，因为那样我就可以放下它，不会在那个项目上浪费更多的时间。此外，此提示的帮助超出您的想象。
更新 21.05.21
splitByChars 工作的前置代码
Sub Unique_Values_Worksheet_Variables()
'1 Code + Sub splitByChars
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:B").EntireColumn.AutoFit
Dim rng As Range:
Set rng = dws.Range("A1:B1", dws.Cells(dws.Rows.Count, 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"
'folgend setzt Sub SplitByChars auf dieser Prozedur Unique_Values_Workesheet_Variables auf
splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1), Chars
ActiveWindow.DisplayGridlines = False
End Sub
但是就像我说的那样，这个前面的代码不再与 spliByChars 结合使用，因为必须调整过滤方法
Sub Unique_Values_Worksheet_Variables()
'1 Code + Sub splitByChars
Const Chars As Long = 4
'Dim wb As Workbook: Set wb = ThisWorkbook
'Dim sws As Worksheet: Set sws = wb.Worksheets("export")
' Source
Const sName As String = "export1"
Const sUniqueColumn As String = "C"
Const sCopyColumnsList As String = "C,I,J" ' exact order of the columns
' Destination (new worksheet)
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
Dim dCell As Range: Set dCell = dws.Range(dFirst)
Application.ScreenUpdating = False
Dim rng As Range
With wb.Worksheets(sName).Range("A1").CurrentRegion
.Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
Dim n As Long
For n = 0 To UBound(sCopyColumns)
.Columns(sCopyColumns(n)).Copy dCell
Set dCell = dCell.Offset(, 1)
Next n
.Parent.ShowAllData
End With
Application.ScreenUpdating = True
dws.Columns("A:J").EntireColumn.AutoFit
Set rng = dws.Range(dCell, dws.Cells(dws.Rows.Count, 1).End(xlUp))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.HorizontalAlignment = xlCenter
'folgend setzt Sub SplitByChars auf dieser Prozedur Unique_Values_Workesheet_Variables auf
splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1), Chars
ActiveWindow.DisplayGridlines = False
End Sub
它必须完全像这样工作
Option Explicit
Sub mymacro()
Dim wb As Workbook, ws As Worksheet
Dim iLastRow As Long, i As Long
Dim sPcent As String, s As String, colD As String, colE As String
Dim dict, key, ar
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set dict = CreateObject("Scripting.Dictionary")
' process data
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
For i = 3 To iLastRow
s = ws.Cells(i, "H")
sPcent = Format(ws.Cells(i, "I"), "0.00")
If Len(s) > 4 Then
colD = Left(s, Len(s) - 4)
colE = Right(s, 4)
Else
colD = s
colE = ""
End If
key = colD & vbTab & sPcent
If dict.exists(key) Then
If Len(colE) > 0 Then
dict(key) = dict(key) & "," & colE
End If
Else
dict.Add key, colE
End If
Next
' output result
ws.Range("D1:G1") = Array("a", "b", "c", "d")
ws.Columns("D:G").NumberFormat = "@"
i = 2
For Each key In dict.keys
ar = Split(key, vbTab) 'colD,pcent
ws.Cells(i, "D") = ar(0)
ws.Cells(i, "E") = dict(key)
ws.Cells(i, "F") = ar(1)
ws.Cells(i, "G") = "%"
i = i + 1
Next
MsgBox "Done"
End Sub
我想在 D:F
中实现以下结果4 位数字分配给 D 列中的正确数字，F 列中的每个百分比分配给 E 列中的正确值。
我使用了以下代码作为拆分部分（fe. 40218 在 D 列中变为 40，在 E 列中变为 0218），当然得到了本论坛的大量帮助。该代码是由前面的子程序调用的子程序。我不能再结合使用两者，因为我已经通过其高级过滤器更改了前面的代码（首先它仅在您可以在 H 列中看到的输出上进行过滤，我对其进行了调整，因此 I 和 J 列也提交给了输出范围）。无论如何，如果我使用 H:J 作为起点，那对我来说很好。这只是为了快速解释为什么 sub splitByChars 包含参数 ByRef & ByVal
所以范围 H:J 是新的起点零。
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
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
此代码的问题是 D 中缺少位数少于 2 的所有值。Chars were declared in the precending code =4 因为在列 E 中，数字始终为 4 位数 length
所以问题 1 出现了：并非所有 D 中的值都显示出来，因为并非所有值都在列
中的至少一位数字后面有 4 位数字H出现的第二个问题是
D中的偶数是 unique 通过它们在I列中的值显示差异，所以我不能 将所有值相加，例如从 4 到 4，因为百分比来自 示例 40218 是 15% 而不是像其他 50% 分配给 4.
这对我来说真的很重要，你们都知道我真的不想浪费你们的时间来寻找一个解决所有问题的代码。我是初学者，我理解的越来越多，但这已经超出了我对 VBA.
逻辑和知识水平的理解和技能。如果您认为这很容易，我非常感谢您的帮助。如果你说，“伙计，这是不可能的”也很好，因为那样我就可以放下它，不会在那个项目上浪费更多的时间。此外，此提示的帮助超出您的想象。
更新 21.05.21 splitByChars 工作的前置代码
Sub Unique_Values_Worksheet_Variables()
'1 Code + Sub splitByChars
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:B").EntireColumn.AutoFit
Dim rng As Range:
Set rng = dws.Range("A1:B1", dws.Cells(dws.Rows.Count, 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"
'folgend setzt Sub SplitByChars auf dieser Prozedur Unique_Values_Workesheet_Variables auf
splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1), Chars
ActiveWindow.DisplayGridlines = False
End Sub
但是就像我说的那样，这个前面的代码不再与 spliByChars 结合使用，因为必须调整过滤方法
Sub Unique_Values_Worksheet_Variables()
'1 Code + Sub splitByChars
Const Chars As Long = 4
'Dim wb As Workbook: Set wb = ThisWorkbook
'Dim sws As Worksheet: Set sws = wb.Worksheets("export")
' Source
Const sName As String = "export1"
Const sUniqueColumn As String = "C"
Const sCopyColumnsList As String = "C,I,J" ' exact order of the columns
' Destination (new worksheet)
Const dFirst As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
Dim dCell As Range: Set dCell = dws.Range(dFirst)
Application.ScreenUpdating = False
Dim rng As Range
With wb.Worksheets(sName).Range("A1").CurrentRegion
.Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
Dim n As Long
For n = 0 To UBound(sCopyColumns)
.Columns(sCopyColumns(n)).Copy dCell
Set dCell = dCell.Offset(, 1)
Next n
.Parent.ShowAllData
End With
Application.ScreenUpdating = True
dws.Columns("A:J").EntireColumn.AutoFit
Set rng = dws.Range(dCell, dws.Cells(dws.Rows.Count, 1).End(xlUp))
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.HorizontalAlignment = xlCenter
'folgend setzt Sub SplitByChars auf dieser Prozedur Unique_Values_Workesheet_Variables auf
splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1), Chars
ActiveWindow.DisplayGridlines = False
End Sub
它必须完全像这样工作
Option Explicit
Sub mymacro()
Dim wb As Workbook, ws As Worksheet
Dim iLastRow As Long, i As Long
Dim sPcent As String, s As String, colD As String, colE As String
Dim dict, key, ar
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set dict = CreateObject("Scripting.Dictionary")
' process data
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
For i = 3 To iLastRow
s = ws.Cells(i, "H")
sPcent = Format(ws.Cells(i, "I"), "0.00")
If Len(s) > 4 Then
colD = Left(s, Len(s) - 4)
colE = Right(s, 4)
Else
colD = s
colE = ""
End If
key = colD & vbTab & sPcent
If dict.exists(key) Then
If Len(colE) > 0 Then
dict(key) = dict(key) & "," & colE
End If
Else
dict.Add key, colE
End If
Next
' output result
ws.Range("D1:G1") = Array("a", "b", "c", "d")
ws.Columns("D:G").NumberFormat = "@"
i = 2
For Each key In dict.keys
ar = Split(key, vbTab) 'colD,pcent
ws.Cells(i, "D") = ar(0)
ws.Cells(i, "E") = dict(key)
ws.Cells(i, "F") = ar(1)
ws.Cells(i, "G") = "%"
i = i + 1
Next
MsgBox "Done"
End Sub