排序，循环并复制到单元格值名称为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