VBA从主表复制一行然后添加到每个提取表中的数据底部

Question

我的主表 (JV501) 最底部的一行是我需要在迄今为止提取的每张表中复制的行。它也需要复制到数据的每个底部。

futureuse          |          Price        |        Credit             |     Currency   | 
-------------------------------------------------------------------------------------------
300x               |          6151500      |                           |          EUR   |
300x               |          6151500      |                           |          USD   |
300x               |          6151500      |        8896684.6          |

上面是一个示例数据，我提取的每个数据都需要复制带有 Credit 的第三行，我已经根据“货币列”提取了工作表

    Option Explicit
    Sub SortCurrency()

    Dim currRange As Range, dataRng As Range, currCell As Range
    Call DeleteSheets
    Dim lastcol As Long
    Dim lastrow As Long
    Dim lastrow2 As Long
    Dim Idx As Variant

    With Worksheets("JV501")
    .Select
        Set currRange = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
        Set dataRng = Intersect(.UsedRange, currRange.EntireRow)
        lastcol = Range("A1").End(xlToRight).Column
        lastrow = Range("AB2").End(xlDown).Row
        Range("AB2:AB" & lastrow).sort key1:=Range("AB2" & lastrow), _
        order1:=xlAscending, Header:=xlNo

        With .UsedRange
            .Resize(1, 1).Offset(0, lastcol - 1).Select
             With .Resize(1, 1).Offset(0, lastcol)
                With .Resize(currRange.Rows.Count)
                .Value = currRange.Value
                .RemoveDuplicates Array(1), Header:=xlYes
                Range("AB:AB").Copy Destination:=Worksheets("Checklist").Range("A1")
                For Each currCell In .SpecialCells(xlCellTypeConstants)
                    currRange.AutoFilter , field:=1, Criteria1:=currCell.Value

                    If Application.WorksheetFunction.Subtotal(103, currRange) - 1 > 0 Then
                        dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
                        Range("A:A").EntireColumn.Delete
                        Range("J:Q").EntireColumn.Delete
                        Columns("A:V").Select
                        Selection.EntireColumn.AutoFit
                    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
    Sub DeleteSheets()
       Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
    If ws.Name <> "JV501" And ws.Name <> "details" And ws.Name <> "removed" And ws.Name <> "Checklist" Then ws.Delete
    Next
    Application.DisplayAlerts = True

    End Sub
    Sub countCurrency()

     Dim sffCount As Long
     Dim ws As Worksheet
     Set ws = Sheets("Checklist")
     Dim lastrow As Long
     lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
     Dim Idx As Variant

     For Idx = 2 To lastrow

     sffCount = Application.WorksheetFunction.CountIf(ws.Range("A1:A" & ws.Rows.Count), ws.Cells(Idx, "A").Value)

     ws.Cells(Idx, "B") = sffCount


 Next

 End Sub

对不起，如果它很长，因为我也尝试获取我的货币计数（在 Sub countCurrency 下）并复制到另一个名为“清单”的工作表，这也是我需要排序和过滤的问题

非常感谢您的每一次帮助！！！

Answer 1

搞定了

With Worksheets("JV501")

 Dim copyS As Range, copyR As Range,
    Set copyR = Range("R" & Rows.Count).End(xlUp) 'find lastrow of column R
    Set copyS = Range("S" & Rows.Count).End(xlUp)

然后在我的 if 循环下

internalR = Range("R" & Rows.Count).End(xlUp).Row + 1
                            copyR.copy Destination:=Range("R" & internalR)

                            internalS = Range("S" & Rows.Count).End(xlUp).Row + 1
                            copyS.copy Destination:=Range("S" & internalS)

这将添加到我的借记列的最后一行 +1