ExcelVBA重新格式化資料

我有一些資料總是 8 列（AH），每次的行數都可能不同（動態）。

如果 A 列中的字串以“IT”、“LN”或“SJ”結尾，則 G 列中的行值需要除以 100。

如果字串以“KK”結尾，則 G 列中的值需要除以 1000。

否則不需要對該行執行數學運算。

資料還需要按 C 列的字母順序排序，然后按 H 列排序。

完成此操作后，標題行 (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

樣本輸入資料

所需的輸出資料：

uj5u.com熱心網友回復：

請嘗試下一個緊湊且快速的代碼。它將要處理的范圍放在一個陣列中，并在最后下拉處理結果。現在它回傳覆寫現有范圍。它可以很容易地適應在另一張紙中回傳：

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

幾個小時前，當我離開辦公室時，我在另一個執行緒中錯誤地發布了這個答案...

只是看看如何使用陣列，以提高更大范圍的速度。

uj5u.com熱心網友回復：

試試這個。它將所有內容復制到新作業表中，這樣您就不會丟失原始資料。如果您有大量資料，可以加快速度。

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

標籤：擅长 vba

上一篇：如何使用VBA截取應用程式并保存它

下一篇：回圈VlookupVBA