排序，循環並復制到單元格值名稱為VBA的新工作表中

Question

我知道這已經被問過很多次了，但是我在VBA上遇到了麻煩，我對VBA還是很陌生。 我正在使用一個具有工作表的工作簿。 基本上，我需要對“貨幣”列進行排序，目前有14種貨幣，我需要遍歷它（因為貨幣可能會隨時間增加，具體取決於客戶），然后將復制條件的行粘貼到具有其單元格值的另一張工作表中。 我的代碼如下。

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

我基本上從研究中得到了代碼，將它們加起來卻沒有達到我想要的方式。 我想保留標頭和帶有條件的值，即，按照上面的示例，貨幣列“ AB”為USD，但是問題是編碼很多，因為我必須遍歷所有14種貨幣將會添加新的貨幣，我也知道有一種不聲明多張工作表的方法，而只是擁有另一個具有單元格值名稱的新工作表，但是我很難一次完成所有工作。 是否會有更簡單，更強大的代碼。 我非常感謝。

Answer 1

您所擁有的一切已經非常接近了，但是有幾點需要注意：

On Error Resume Next通常是一個錯誤的計划，因為它可能隱藏很多錯誤。 我在下面的代碼中使用了它，但這僅僅是因為我立即處理了可能發生的任何錯誤。

xCell.Value.Range("A" & J + 1)毫無意義。 xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)該行的中間以保留xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)

與其檢查該值是否為特定貨幣，不如查看其值是什么貨幣，並對其進行適當處理。

使用J作為計數器可用於一種貨幣，但是在處理多種貨幣時，僅需檢查其在運行中會更容易。

總而言之，下面的代碼應該與您要查找的內容接近。

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

好的，這里發生了很多事情……我將一次嘗試解決一個問題。

1-您可以測試工作表是否已經存在，而不是每次都創建它

假設您想對循環中的每種貨幣進行操作，建議您不要使用當前使用的if條件“ if value =“ USD”“，而應使用單元格值來確定名稱表的大小，無論單元格值是多少。

首先，您需要一個單獨的函數來測試工作表是否存在，例如

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

然后，您可以在代碼中調用此函數，並且僅在需要

2-循環本身

因此，我建議您的循環可能要看起來像這樣：

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

使用此設置，對於每種貨幣，您的循環將xSheet設置為已存在的貨幣表，或創建該表。 假設您要對所有貨幣執行相同的操作，否則，將需要添加額外條件

3-復制/粘貼行本身

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

我不認為此代碼說明了您的想法-該代碼實際上說的是“將整個行復制到最后一張工作表的名稱，並使其等於xCell在A，（J）+1處的值范圍內

我認為您真正想說的是：

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

但是，如果您使用的是我上面提供的代碼，則可以立即使用：

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

實際上，這樣做會更好，特別是如果工作表已經存在並且被DidSheetExist提取的話

就我個人而言，我也寧願轉移價值，也不願在任何一天使用復制/粘貼，但這只是一種效率，上面的方法應該可以正常工作。

Answer 3

您可能想嘗試此代碼，利用Range對象的Autofilter()方法

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