根据另一个 sheet 的条件多次复制一组数据

Question

Excel 2010. 我正在尝试编写一个宏，可以根据另一个 sheet 的条件多次复制一组数据，但我已经卡住了很长时间。我非常感谢任何可以帮助我解决这个问题的帮助。

第 1 步：在 "Criteria" 工作sheet 中，共有三列，每行包含特定的数据组合。第一组组合为"USD, Car".

第二步：然后宏会移动到输出工作sheet（请参考下面的link截图），然后用第一组条件过滤A列和B列"USD" 和 "Car" 在 "Criteria" 工作 sheet.

第3步：之后，宏会将过滤后的数据复制到最后一个空白行中。但这里比较棘手的是，过滤后的数据要复制两次（因为"Criteria"选项卡中的"Number of set"列在这个组合中是3，它不必复制数据三次，因为过滤后的数据将被视为第一组数据）

Step4：复制过滤后的数据后，"Set"列D需要填写行所在集合的相应编号。因此，在第一个示例中，单元格D2和D8将具有“1”值，单元格 D14-15 将具有“2”值，而单元格 D16-17 将具有“3”值。

Step5: 然后宏会移回"Criteria"工作sheet继续根据第2组组合"USD, Plane"过滤[=39]中的数据=]工作sheet。同样，它会根据 "Criteria" 作品sheet 中的 "Number of set" 复制过滤后的数据。此过程将继续，直到 "Criteria" 工作sheet 中的所有不同组合都已处理。

Output worksheet

Answer 1

好的，抱歉耽搁了，这是一个工作版本

你只需要添加一个名为 "BF" 的 sheet 因为自动过滤器计数不能正常工作所以我不得不使用另一个 sheet

Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To EndRow
        Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
    Next i

End Sub

Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")

Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer

ColCr1 = 1
ColCr2 = 2
ColRef = 4

If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False

Dim RgTotal As String
RgTotal = "$A:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row

ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1

Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1


Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
    'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
    'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1


Dim RgDest As String

ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
    'define number set
    For j = 1 To VR
        ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
    Next j
    RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
    Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)

Next k

ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub

以及使用整数输入获取列字母的函数：

Function ColLet(x As Integer) As String
  With ActiveSheet.Columns(x)

        ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)

    End With
End Function

根据另一个 sheet 的条件多次复制一组数据

Copy a set of data multiple times based on criteria on another sheet

excel

vba

loops

filter

copy-paste