Question

我有一个关于如何添加到此代码以不复制重复行的问题。我的A，C和D列组合在一起会形成一个唯一的标识符，但我不必添加＆＃34; helper＆＃34;如果可能的话，列到我的电子表格。

Option Explicit

Public Sub CopyRows()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws1r As Range, ws2r As Range
    Dim ws1lr As Long, ws1lc As Long, ws2lr As Long, i As Long

    Set ws1 = ThisWorkbook.Worksheets("2")
    Set ws2 = ThisWorkbook.Worksheets("Core_Cutter_List")

    ws1lr = ws1.Range("A" & Rows.Count).End(xlUp).Row        'last row in "2"
    ws1lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column 'last col in "2"
    ws2lr = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1    'last row in "Core_Cutter"

    For i = 1 To ws1lr

        If Len(ws1.Cells(i, "A")) > 0 And Len(ws1.Cells(i, "G")) = 0 Then

            Set ws1r = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1lc))
            Set ws2r = ws2.Range(ws2.Cells(ws2lr, 1), ws2.Cells(ws2lr, ws1lc))

            ws2r.Value2 = ws1r.Value2
            ws2lr = ws2lr + 1
        End If

    Next i

End Sub

Answer 1

我建议在现有循环之前添加一个for..next循环，并在for..next循环中创建一个包含每行唯一标识符的数组（由A，C，D中的单元格构成）。然后你可以使用那个数组来确保在以下for..next循环中没有进行任何更改，如果已经完成了一行。

我快速将下面的代码放在一起，没有简单的方法可以在没有数据的情况下检查它，因此需要修改。但至少它会给你一个想法。如果您有疑问，请告诉我。

Option Explicit

Public Sub CopyRows()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws1r As Range, ws2r As Range
    Dim ws1lr As Long, ws1lc As Long, ws2lr As Long, i As Long
    Dim copyArr() As String, aCopy As Boolean, j As Long

    Set ws1 = ThisWorkbook.Worksheets("2")
    Set ws2 = ThisWorkbook.Worksheets("Core_Cutter_List")

    ws1lr = ws1.Range("A" & Rows.Count).End(xlUp).Row        'last row in "2"
    ws1lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column 'last col in "2"
    ws2lr = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1    'last row in "Core_Cutter"

    ReDim copyArr(1 To ws1lr) As String
    For i = 1 To ws1lr
      copyArr(i) = ws1.Cells(i, "A") + ws1.Cells(i, "C") + ws1.Cells(i, "D")
    Next

    For i = 1 To ws1lr
      aCopy = False
      For j = 1 To ws1lr
        If i <> j And copyArr(i) = copyArr(j) Then
          aCopy = True
          Exit For
        End If
      Next j

      If Not aCopy Then

        If Len(ws1.Cells(i, "A")) > 0 And Len(ws1.Cells(i, "G")) = 0 Then

            Set ws1r = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1lc))
            Set ws2r = ws2.Range(ws2.Cells(ws2lr, 1), ws2.Cells(ws2lr, ws1lc))

            ws2r.Value2 = ws1r.Value2
            ws2lr = ws2lr + 1
        End If

      End If
    Next i

End Sub

这是一个测试子，用于解决您遇到问题的代码。因为您在评论中提到的7 3/4的值可能会给Excel单元格带来麻烦，所以我将A列中的单元格格式化为文本。

Sub test()
Dim ws1 As Worksheet, s As String
Dim i As Integer, copyArr() As String
Set ws1 = ActiveSheet
ReDim copyArr(1 To 3) As String
For i = 1 To 3
  copyArr(i) = CStr(ws1.Cells(i, "A")) + CStr(ws1.Cells(i, "C")) + CStr(ws1.Cells(i, "D"))
  ws1.Cells(i, "D") = copyArr(i)
Next i
End Sub

Answer 2

这种方法使用字典来捕获已经存在于＆＃34; Core_Cutter_List＆＃34;中的记录如果第二张纸中已存在记录，则不会再从第一张纸中复制该记录（＆＃34; 2＆＃34;）

Option Explicit

Public Sub CopyRows()
    Const A = 1, C = 3, D = 4, IDK = "|"
    Dim ws1 As Worksheet, ws2 As Worksheet, i As Long, j As Long, recordID As String
    Dim ws1ur As Variant, ws2ur As Variant, ws1lc As Long, dic As Object

    Set ws1 = ThisWorkbook.Worksheets("2")
    Set ws2 = ThisWorkbook.Worksheets("Core_Cutter_List")

    ws1ur = ws1.UsedRange           'all data in "2" (as array)
    ws2ur = ws2.UsedRange           'all data in "Core_Cutter" (as array)
    ws1lc = UBound(ws1ur, 2)        'last col in "2"
    j = UBound(ws2ur, 1) + 1        'last row in "Core_Cutter"

    Set dic = CreateObject("Scripting.Dictionary")  'Capture IDs in ws2, cols A, C, & D
    For i = 1 To j - 1
        dic(ws2ur(i, A) & IDK & ws2ur(i, C) & IDK & ws2ur(i, D)) = 0
    Next i

    For i = 1 To UBound(ws1ur, 1)   'last row in "2"

        If Len(ws1ur(i, 1)) > 0 And Len(ws1ur(i, 7)) = 0 Then

            recordID = ws1ur(i, A) & IDK & ws1ur(i, C) & IDK & ws1ur(i, D)

            If Not dic.Exists(recordID) Then  'check that the record in ws1 is not in ws2
                dic(recordID) = 0             'add it to the dictionary
                ws2.UsedRange.Rows(j).Value2 = ws1.UsedRange.Rows(i).Value2  'Copy rows
                j = j + 1
            End If
        End If
    Next i
End Sub

在工作表中测试数据（＆＃34; 2＆＃34;）

结果 - 工作表（＆＃34; Core_Cutter_List＆＃34;）

不复制重复的行

2 个答案: