Question

请查看附件图片

这只是虚拟数据。

我的要求是

如果内部资产ID（B列）是唯一的，则复制行，无论是否选中（F列）。
如果内部资产ID不唯一，即B列中存在相同的内部资产ID 不止一次，请查看哪个内部资产ID是F列，标记为已选中＆amp;然后只复制那一行。
复制的行有：第3行，第5行，第7行，第8行，第9行＆＃34;

这个数据在Workbook1：Sheet1中，我必须将它复制到Workbook2：Sheet2复制＆amp;的映射。粘贴必须如下所述 -

WB1:Sheet1 A to WB2:Sheet2 A
WB1:Sheet1 B to WB2:Sheet2 B
WB1:Sheet1 N to WB2:Sheet2 C
WB1:Sheet1 X to WB2:Sheet2 D
WB1:Sheet1 Y to WB2:Sheet2 E
WB1:Sheet1 AY to WB2:Sheet2 G
WB1:Sheet1 C to WB2:Sheet2 H
WB1:Sheet1 D to WB2:Sheet2 I
WB1:Sheet1 E to WB2:Sheet2 J
WB1:Sheet1 F to WB2:Sheet2 K
WB1:Sheet1 BI to WB2:Sheet2 R
WB1:Sheet1 AT to WB2:Sheet2 S
WB1:Sheet1 AU to WB2:Sheet2 T
WB1:Sheet1 AV to WB2:Sheet2 U
WB1:Sheet1 AW to WB2:Sheet2 V

Workbook2中的粘贴：Sheet2必须从＆＃34; A12＆＃34;

开始

我的尝试：

Sub cpyCol()
    Dim wc As Worksheet, wa As Worksheet
    Dim lr As Long, I As Long, J As Long
    Dim uR As Range
    Dim eNumStorage() As String ' initial storage array to take values
    Dim x As String

    Set wc = Sheets("Test")
    Set wa = Sheets("Test")
    lr = wc.Range("A" & Rows.Count).End(xlUp).Row
    ReDim eNumStorage(1 To lr - 2)

    Application.ScreenUpdating = False
    For I = 3 To lr 'sheets all have headers that are 2 rows
        If (Not IsEmpty(Cells(I, 2).Value)) Then ' checks to make sure the value isn't empty
            J = J + 1
            eNumStorage(J) = Cells(I, 2).Value ' to store values of internal Asset ID in an array
        End If
        If wc.Range("F" & I) = "Selected" Then 'check if column F is marked as selected
            If (uR Is Nothing) Then
                Set uR = Range(I & ":" & I)
            Else
                Set uR = Union(uR, Range(I & ":" & I))
            End If
        End If
    Next I
    uR.copy Destination:=wa.Range("A13")
    Application.ScreenUpdating = True
End Sub

结果（对于测试我只是尝试从同一张表复制和粘贴到同一张纸上） -

我可以复制在F列
我可以将内部资产ID的值存储在数组eNumStorage（）中的B列中
所以我可以复制第3行和第5行

我需要帮助的地方 -

无法复制第7行，第8行和第9行。

我试图复制第7行，第8行和第9行

 If eNumStorage(J) = eNumStorage(J + 1) Then
        If wc.Range("F" & I) = "Selected" Then 'check if column F is marked as selected
            If (uR Is Nothing) Then
                Set uR = Range(I & ":" & I)
            Else
                Set uR = Union(uR, Range(I & ":" & I))
            End If
        End If
    End If

问题 - 不适用于以后的行

非常感谢任何帮助。谢谢。

Answer 1

好吧，我找到了一个完全符合我想要的解决方案。感谢@PEH的帮助。

Sub cpyCol()
    Dim wc As Worksheet, wa As Worksheet
    Dim lr As Long, I As Long, J As Long, I2 As Long
    Dim uR As Range
    Dim wb, wb1 As Workbook
    Dim eNumStorage() As String ' initial storage array to take values
    Set wb = Workbooks.Open("C:\Users\Z003U8UC\Downloads\PP_Anan.xlsm")
    Set wb1 = ThisWorkbook
    Set ws = wb.Sheets("Procurement plan PM80 ->")
    Set wa = ThisWorkbook.Sheets("Test")
    lRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(-3).Row
    I2 = 11
    Const fRow As Long = 2
    Application.ScreenUpdating = False
    For I = 2 To lRow 'sheets all have headers that are 2 rows
        If Not (Application.WorksheetFunction.CountIf(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & I)) > 1 And _
        Application.WorksheetFunction.CountIfs(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & I), ws.Range("AY" & fRow, "AY" & lRow), "Selected") = 1 _
        And ws.Range("AY" & I) <> "Selected") Then
'            If (uR Is Nothing) Then
'                Set uR = Range(I & ":" & I)
'            Else
'                Set uR = Union(uR, Range(I & ":" & I))
'            End If
            I2 = I2 + 1
            wa.Cells(I2, "A") = ws.Cells(I, "A")
            wa.Cells(I2, "B") = ws.Cells(I, "B")
            wa.Cells(I2, "C") = ws.Cells(I, "N")
            wa.Cells(I2, "D") = ws.Cells(I, "X")
            wa.Cells(I2, "E") = ws.Cells(I, "Y")
            wa.Cells(I2, "G") = ws.Cells(I, "AY")
            wa.Cells(I2, "H") = ws.Cells(I, "C")
            wa.Cells(I2, "I") = ws.Cells(I, "D")
            wa.Cells(I2, "J") = ws.Cells(I, "E")
            wa.Cells(I2, "K") = ws.Cells(I, "F")
            wa.Cells(I2, "R") = ws.Cells(I, "BI")
            wa.Cells(I2, "S") = ws.Cells(I, "AT")
            wa.Cells(I2, "T") = ws.Cells(I, "AU")
            wa.Cells(I2, "U") = ws.Cells(I, "AV")
            wa.Cells(I2, "V") = ws.Cells(I, "AW")
        End If
    Next I
    'uR.copy Destination:=ws.Range("A13")
    wb.Save
    wb.Close
    Application.ScreenUpdating = True
End Sub

如果可以进一步提高速度，请告诉我。

Answer 2

要确定哪个行必须复制，哪个不能使用此公式在G栏中

=IF(AND(COUNTIF(B:B,B:B)>1,COUNTIFS(B:B,B:B,F:F,"Selected")=1,F:F<>"Selected"),"-","copy")

现在，您甚至可以使用过滤器按列G进行过滤。

<强>解释

COUNTIF(B:B,B:B)计算“AssetID”的出现次数。因此，如果>1 ID不唯一，则这是对唯一性的测试。
COUNTIFS(B:B,B:B,F:F,"Selected")计算“已选择”的非唯一“AssedID”的出现次数。因此，如果这是=1，则表示其中一个ID已标记为已选中。
F:F<>"Selected"表示未选择ID

总的来说，公式意味着：将所有ID标记为Copy，但要排除这些......

不是唯一的
并非唯一且未选中
未选中

这基本上意味着，将所有标记为副本的内容为：

独特
OR非唯一且已选中
或者已选择

或者VBA的例子
使用几乎相同的公式。

Sub Example()
    Dim ws As Worksheet
    Set ws = Worksheets("Tabelle3") 'your worksheet

    Dim lRow As Long 'last used row
    lRow = ws.Cells(ws.Cells.Rows.Count, "A").End(xlUp).Row

    Const fRow As Long = 3 'first row with data


    Dim i As Long
    For i = fRow To lRow 'run from first data row to last
        If Not (Application.WorksheetFunction.CountIf(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & i)) > 1 And _
           Application.WorksheetFunction.CountIfs(ws.Range("B" & fRow, "B" & lRow), ws.Range("B" & i), ws.Range("F" & fRow, "F" & lRow), "Selected") = 1 And _
           ws.Range("F" & i) <> "Selected") Then

            'copy this line

        End If
    Next i
End Sub

检查行条件以从1个工作簿复制并粘贴到另一个

2 个答案: