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

我基本上是从我的研究中得到代码，将它们加起来，而不是按照我想要的方式。我想保留标题和带有标准的值， i,e 货币列“AB”是美元，如上例所示，但问题是它会进行大量编码，因为我必须检查所有 14 种货币，以及是否会添加新货币， 我也知道有一种方法可以不声明多张工作表，而只是拥有另一个带有单元格值名称的新工作表，但是我在一次完成所有工作时遇到了问题。如果会有更简单和强大的代码。非常感谢。

Answer 1

你可能想试试这段代码，利用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

Answer 2

你已经很接近你所拥有的，但有几点需要注意：

On Error Resume Next 通常是一个糟糕的计划，因为它可以隐藏很多罪恶。我在下面的代码中使用它，但这只是因为我会立即处理可能发生的任何错误。

xCell.Value.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 3

好的，这里发生了很多事情......我将尝试一次解决一个问题。

1 - 您可以测试工作表是否已经存在，而不是每次都创建它

假设您想为循环中的每种货币做一些事情，我建议不要使用您目前使用的 if 条件“if value = "USD"",而是使用单元格值来确定工作表的名称，无论单元格值是什么。

首先你需要一个单独的函数来测试sheet是否存在，比如

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)

事实上，你最好这样做，特别是如果床单有可能已经存在并被DoesSheetExist拾取

就我个人而言，我也宁愿传递价值而不是任何一天使用复制/粘贴，但这只是一个效率问题，上面应该可以正常工作。