excel - 如何得到这个结果?
问题描述
我想在 D:F 中实现以下结果
4 位数字分配给 D 列中的正确数字,F 列中的每个百分比都分配给 E 列中的正确值。
我将以下代码用于拆分部分(fe. 40218 在 D 列中变为 40,在 E 列中变为 0218),当然在这个论坛有很多帮助。该代码是由前面的子调用的子。我不能再将两者结合使用,因为我已经通过其高级过滤器更改了前置代码(首先它仅在您可以在 H 列中看到的输出上进行过滤,我对其进行了调整,因此 I 和 J 列也被提交给输出范围)。无论如何,如果我使用它H:J
作为我的起点,这对我来说很好。这只是一个快速解释为什么sub splitByChars
包含参数ByRef & ByVal
所以 RangeH: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 位长度
所以出现问题 1:并非 D 中的所有值都显示出来,因为并非所有值都在列中至少一位数字后面有 4 位数字
H
出现的第二个问题是,即使
D
是唯一的值也会通过它们在列中的值显示差异I
,所以我不能总结所有值,例如从 4 到 4,因为例如 40218 的百分比是 15% 而不是 50%就像分配给4的其他人一样。
对我来说非常重要的是,你们都知道我真的不想用你们的时间来寻找解决所有问题的代码。我是一个初学者,我一天比一天了解更多,但这远远超出了我对 VBA 逻辑和知识水平的理解和技能。
如果您有任何机会认为这很容易,我非常感谢您的帮助。如果你说,“伙计,这是不可能的”也很好,因为这样我就可以放下它,不再在那个项目上浪费更多时间。此外,此提示的帮助超出您的想象。
更新 splitByChars 工作的 21.05.21 前置代码
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