排序，循环并复制到单元格值名称为VBA的新工作表中

Question

I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA. I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value. my code below.

Option Explicit
    Sub SortCurrency()
        Dim rng As Range
        Dim xCell As Range
        Dim I As Long
        Dim J As Long
        I = Worksheets("Sheet1").UsedRange.Rows.Count
        J = Worksheets("Sheet2").UsedRange.Rows.Count
        If J = 1 Then
           If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
        End If
        Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
        On Error Resume Next
        Application.ScreenUpdating = False
        For Each xCell In rng
            If CStr(xCell.Value) = "USD" Then
                Sheets.Add After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = xCell.Value
                xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
                'Sheets.Add After:=Sheets(Sheets.Count)
                'Sheets(Sheets.Count).Name = xCell.Value
                Application.CutCopyMode = False

                J = J + 1
            End If
        Next
        Application.ScreenUpdating = True
    End Sub

I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria, i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added, also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.

Answer 1

You're pretty close with what you've got, but there's a few things to note:

On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.

xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)

Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.

Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.

All told, the below code should be close to what you're looking for.

Option Explicit
Sub SortCurrency()
    Dim rng As Range
    Dim xCell As Range
    Dim targetSheet As Worksheet
    Dim I As Long
    Dim J As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
    Application.ScreenUpdating = False
    For Each xCell In rng
        Set targetSheet = Nothing
        On Error Resume Next
            Set targetSheet = Sheets(xCell.Value)
        On Error GoTo 0
        If targetSheet Is Nothing Then
            Sheets.Add After:=Sheets(Sheets.Count)
            Set targetSheet = Sheets(Sheets.Count)
            targetSheet.Name = xCell.Value
            xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
        Else
            xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
        End If
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
End Sub

Answer 2

OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.

1 - You could do with testing whether a worksheet already exists rather than creating it every time

Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.

First of all you need a seperate function to test whether the sheet exists, like

Public Function DoesSheetExist(SheetName as String)
  On Error Resume Next

  Dim WkSheet as WorkSheet
  'sets worksheet to be the sheet NAMED the current currency name
  Set WkSheet = Sheets(SheetName)
  'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists

  If WkSheet is Nothing Then
    DoesSheetExist = False
Else
    DoesSheetExist = True
End If

End Function

You can then call this function in your code, and only create new sheets when you need to

2 - The loop itself

So instead, I would suggest your loop probably wants to look more like this:

Dim xSheet as Worksheet   'declare this outside the loop

For Each xCell In rng
   If DoesSheetExist(xCell.Value) Then
       set xSheet = Sheets(xCell.Value)  'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index

   Else
       set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
       xSheet.Name = xCell.Value
   End if

With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in

3 - the copy/paste line itself

 xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)

I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1

I think what you actually wanted to say was this:

 xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)

However, if you're using the code I gave you above you can instead use this now:

 xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)

In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist

Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.

Answer 3

you may want to try this code, exploiting Autofilter() method of Range object

Option Explicit

Sub SortCurrency()
    Dim currRng As Range, dataRng As Range, currCell As Range

    With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
        Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
        Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
        With .UsedRange
            With .Resize(1, 1).Offset(, .Columns.Count)
                With .Resize(currRng.Rows.Count)
                    .Value = currRng.Value
                    .RemoveDuplicates Array(1), Header:=xlYes
                    For Each currCell In .SpecialCells(xlCellTypeConstants)
                        currRng.AutoFilter field:=1, Criteria1:=currCell.Value
                        If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
                            dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
                        End If
                    Next currCell
                    .ClearContents
                End With
            End With
        End With
        .AutoFilterMode = False
    End With
End Sub


Function GetOrCreateWorksheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateWorksheet = Worksheets(shtName)
    If GetOrCreateWorksheet Is Nothing Then
        Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
        GetOrCreateWorksheet.name = shtName
    End If
End Function