Excel VBA Reformat Data-CodePudding

I have some data that will always be 8 columns (A-H) the number of rows could be different every time (Dynamic).

If the string in column A ends with: "IT", "LN" or "SJ" then the row value in Column G needs to be divided by 100.

If the string ends in "KK" the value in Column G needs to be divided by 1000.

Otherwise no math operation to the row needs to be performed.

The data also needs to be sorted alphabetically by column C then by column H.

After this is done the header row (1). Can be deleted.

What I have so far "works" but it results in a very long list of 0.0000 values in column G that makes copying out the cleaned data difficult.

Would anyone be able to show me a more efficient solution?

 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

Sample Input Data

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

Desired Output Data:

CodePudding user response：

Try this. It copies everything to a new sheet so you don't lose the original data. Could be sped up if you have lots of data.

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