Excel VBA 重新格式化数据

Question

我有一些数据始终为 8 列 (A-H)，每次行数可能不同（动态）。

如果A列中的字符串以： "IT", "LN" or "SJ" 那么G列的行值需要除以100.

如果字符串以“KK”结尾，则 G 列中的值需要为除以 1000。

否则不需要对该行执行数学运算。

数据还需要先按 C 列字母顺序排序，然后再按 H 列排序。

完成后 header 行 (1)。可以删除。

到目前为止，我所拥有的“有效”，但它会在 G 列中产生一个非常长的 0.0000 值列表，这使得复制清理后的数据变得困难。

谁能告诉我更有效的解决方案？

 Sub Clean()

 Dim wkb As Workbook

 Set wkb = ActiveWorkbook

 Dim ws As Worksheet

Set ws = ActiveSheet


Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=Range("H2:H2500" _
    ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    
    
With ws.Sort
    .SetRange Range("A1:H2500")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With



Range("I2").Select
ActiveCell.FormulaR1C1 = _
    "=IF(OR(RIGHT(RC[-8],2) = ""SJ"", RIGHT(RC[-8],2) = ""LN"", RIGHT(RC[-8],2) = ""IT"", RIGHT(RC[-8],2) = ""KK""),IF(RIGHT(RC[-8],2) = ""KK"",RC[-2]/1000,RC[-2]/100),RC[-2])"
Range("I2").Select
Selection.Copy
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Range("I2500").Select
Range(Selection, Selection.End(xlUp)).Select
Range("I3:I2500").Select
Range("I2500").Activate
ActiveSheet.Paste
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Selection.NumberFormat = "0.0000"

  Columns("I").Delete


 Dim strDataRange As Range
 Dim keyRange As Range

 Set strDataRange = Range("A:H")
 Set keyRange = Range("C1")
 strDataRange.Sort Key1:=keyRange, Header:=xlYes
 Rows(1).Delete

 End sub

示例输入数据

Codes	Population	Animal	Type	Size	Housing Qty	Average Cost	Country
SHIB IT	4,504	DOGE	Standard	SMALL	15,019	9.5557	JP
CORG LN	33,052	DOGE	Standard	SMALL	8,816	31,404.9100	FR
SOG SJ	1,417	CAT	Standard	BIG	90	247.2508	ZM
CHOW KK	873	DOGE	Standard	BIG	9,192	177.2797	CN
FLOP AG	991	CAT	Standard	BIG	7	597.0650	BZ

所需的输出数据：

Answer 1

试试这个。它将所有内容复制到一个新的 sheet，这样您就不会丢失原始数据。如果您有大量数据，可以加快速度。

Sub x()

Dim ws As Worksheet, r As Long

Set ws = Worksheets.Add

Sheet1.Range("A1").CurrentRegion.Copy ws.Range("A1") 'assumes data on sheet1 (code name, change to suit)

For r = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
    Select Case Right(ws.Cells(r, 1), 2)
        Case "IT", "LN", "SJ": ws.Cells(r, "G").Value = ws.Cells(r, "G").Value / 100
        Case "KK": ws.Cells(r, "G").Value = ws.Cells(r, "G").Value / 1000
    End Select
Next r

With ws.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=ws.Range("C2:C" & ws.Range("A" & Rows.Count).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add2 Key:=Range("H2:H" & ws.Range("A" & Rows.Count).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:H" & ws.Range("A" & Rows.Count).End(xlUp).Row)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

End Sub

Answer 2

请尝试下一个简洁快速的代码。它会将要处理的范围放在一个数组中，并在最后下拉处理的结果。现在它 return 正在覆盖现有范围。它可以很容易地适应 return 在另一个 sheet:

Sub processRangeAH()
 Dim sh As Worksheet, lastR As Long, rng As Range, arr, i As Long
 
 Set sh = ActiveSheet
 lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
 Set rng = sh.Range("A1:H" & lastR)
 rng.Sort Key1:=sh.Range("H1"), Order1:=xlAscending, Header:=xlYes
 arr = rng.Value2
 
 For i = 2 To UBound(arr)
    Select Case UCase(Right(arr(i, 1), 2))
        Case "IT", "LN", "SJ": arr(i, 7) = arr(i, 7) / 100
        Case "KK": arr(i, 7) = arr(i, 7) / 1000
    End Select
 Next i
 
 rng.Value2 = arr
 rng.Sort Key1:=sh.Range("C1"), Order1:=xlAscending, Header:=xlYes
 sh.Range("G2:G" & lastR).NumberFormat = "0.0000"
 sh.rows(1).Delete
End Sub

几个小时前我离开办公室时发布了这个答案，但不小心在另一个线程中...

只是为了看看如何使用数组，以提高更大范围的速度。

Excel VBA 重新格式化数据

Excel VBA Reformat Data

excel

vba