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

我基本上从我的研究中得到了代码，将它们加起来并没有按照我想要的方式进行。我想用标准保持标题和值，我，e货币栏“AB”是美元，如上例所示，但问题是这将是大量的编码因为我必须通过所有14种货币加上如果将有新的货币将被添加，另外我知道有一种方法可以不声明多个工作表，只是有另一个带有单元格值名称的新工作表，但我遇到了一个问题，一次完成它。如果有一个更简单和强大的代码。我非常感谢。

Answer 1

你与你所拥有的非常接近，但有几点需要注意：

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

On Error Resume Next毫无意义。切断该行的中间以离开xCell.Value.Range("A" & J + 1)

不是检查价值是否是特定货币，而是应该取值，无论货币是什么，并适当地处理它。

使用xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)作为计数器适用于一种货币，但在处理多种货币时，只需检查它应该在哪里运行就更容易了。

总而言之，以下代码应该接近您所寻找的内容。

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)

我认为这段代码不会说你认为它做了什么 - 这段代码实际上说的是“将整行复制到最后一张Sheet的名称，并使其等于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选中

就我个人而言，我宁愿转移价值而不是使用复制/粘贴任何一天，但这只是一个效率的事情，上面应该运行良好。

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

排序，循环，复制到具有单元格值名称VBA

3 个答案: