僅當在另一個作業表中找不到匹配項時，VBA才能復制一系列單元格

僅當新作業表中不存在該行時，才嘗試將以下變數范圍內的資料復制到新作業表中。

我正在使用輔助列，因為只有在未找到兩列中的條件時才應復制單元格。

（場景計算表）

（場景儀表盤）

如果代碼實際有效，則預期輸出：

僅添加了 3.1 & Apple 和 4.2 & Lemon 行。重復的 1.2 & Lemon 沒有額外的行。

我有這個，但它似乎無休止地運行，沒有任何東西被復制。除錯程序似乎結束了，但那是在按住 F8 之后......

Sub CopyToDash()

    Dim main As Worksheet
    Set main = Worksheets("Scenario Calc Table")

    Dim log As Worksheet
    Set log = ThisWorkbook.Worksheets("Scenario Dash")

    Dim searchRange As Range
    Set searchRange = log.Range("R2:R10") 'Helper Column

    Dim RowCount As Integer
    For RowCount = 1 To main.Range("M2:M10").Rows.Count
        Dim lookFor As String
        lookFor = main.Range("M2").Offset(RowCount - 1, 0).Value2 'Uses helper cells

        Dim dupe As Range
        Set dupe = searchRange.Find(lookFor, LookIn:=xlValues)


        Dim copyInfo As Range
        Set copyInfo = searchRange.Range("K2:L40").Offset(RowCount - 1, 0)

        Dim destination As Range
        If dupe Is Nothing Then
            Set destination = log.Range("O" & Rows.Count).End(xlUp).Offset(1)
        Else
            Set destination = dupe
        End If

        destination.Resize(ColumnSize:=copyInfo.Columns.Count).Value2 = copyInfo.Value2
    Next
    
   log.Activate

End Sub

提前致謝 ：）

uj5u.com熱心網友回復：

我將您的范圍轉換為表格，因為它更具動態性。

我創建了一個新的輔助列“ Helper Match ”，如圖所示并插入了公式

=IFERROR(MATCH([@[Helper Col]];tbDash4[Helper Col];0);"NO MATCH")

我認為評論很容易理解。希望你喜歡！

Sub CopyToDash()
    ' Worksheets
    Dim wsCalc As Worksheet: Set wsCalc = Sheets("Scenario Calc Table")
    Dim wsDash As Worksheet: Set wsDash = Sheets("Scenario Dash")
    
    ' Tables
    Dim olCalc As ListObject: Set olCalc = wsCalc.ListObjects("tbCalc")
    Dim olDash As ListObject: Set olDash = wsDash.ListObjects("tbDash")

    ' Clear table filters
    If olCalc.AutoFilter.FilterMode Then olCalc.AutoFilter.ShowAllData
    If olDash.AutoFilter.FilterMode Then olDash.AutoFilter.ShowAllData
    
    ' Filter table
    Dim olCol As Long: olCol = olCalc.ListColumns("Helper Match").Index
    olCalc.Range.AutoFilter Field:=olCol, Criteria1:="NO MATCH"

    ' Check for visible rows
    Dim visibleRows As Long
    If olCalc.ListRows.Count > 0 Then
        On Error GoTo errNoRowsToBeCopied
        visibleRows = olCalc.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count
    End If
    
    ' Set source and destinagion ranges
    Dim srcRng As Range: Set srcRng = olCalc.DataBodyRange.Resize(, 2).SpecialCells(xlCellTypeVisible)
    Dim dstRng As Range: Set dstRng = olDash.HeaderRowRange(olDash.Range.Rows.Count   1, 1)
    
    ' Copy from Calc to Dash
    srcRng.Copy
    dstRng.PasteSpecial (xlPasteValues)
    
    Application.CutCopyMode = False
    
    Exit Sub
    
errNoRowsToBeCopied:
    Debug.Print "No Rows To Be Copied To Dashboard"
End Sub

uj5u.com熱心網友回復：

Sub test()
  Dim c_sh1 As Range
  Dim c_sh2 As Range
  Dim count As Integer
  
  For Each c_sh1 In Range("B1", Range("b1").End(xlDown))
  count = 0
    For Each c_sh2 In Sheets("Sheet2").Range("B1", Sheets("sheet2").Range("B1").End(xlDown))
      If c_sh1 & c_sh1.Offset(0, -1) = c_sh2 & c_sh2.Offset(0, -1) Then
        count = count   1
      End If
    Next c_sh2
      If count = 0 Then
        Sheets("Sheet2").Range("B1").End(xlDown).Offset(1, 0) = c_sh1
        Sheets("Sheet2").Range("A1").End(xlDown).Offset(1, 0) = c_sh1.Offset(0, -1)
      End If
  Next c_sh1
  
End Sub

可能有更簡單的方法，但如果我明白你在嘗試什么，那么它應該可以作業。下面有鏈接你可以檢查excel檔案。

https://docs.google.com/spreadsheets/d/16rMzQ-VLx6jq7tQSby0Kq4od02OYfAMr/edit?usp=sharing&ouid=116818902823034098520&rtpof=true&sd=true

uj5u.com熱心網友回復：

您的代碼所需的更正是

'Set copyInfo = searchRange.Range("K2:L40").Offset(RowCount - 1, 0)
Set copyInfo = main.Range("K2:L2").Offset(RowCount - 1, 0)

 'destination.Resize(ColumnSize:=copyInfo.Columns.Count).Value2 = copyInfo.Value2
 destination.Resize(1,ColumnSize:=copyInfo.Columns.Count).Value2 = copyInfo.Value2

'Set destination = dupe
Set destination = dupe.offset(0,-3)

或使用匹配

Option Explicit
Sub CopyToDash1()

    Dim main As Worksheet, log As Worksheet
    Dim ar, v, lastrow As Long
    Dim r As Long, rLog As Long, n As Long
    
    With ThisWorkbook
        Set main = .Sheets("Scenario Calc Table")
        Set log = .Sheets("Scenario Dash")
    End With
    
    With log
        rLog = .Cells(.Rows.Count, "R").End(xlUp).Row ' helper
        ar = .Range("R2:R" & rLog)
    End With
        
    With main
        lastrow = .Cells(.Rows.Count, "M").End(xlUp).Row ' helper
        For r = 2 To lastrow
            v = Application.Match(.Cells(r, "M"), ar, 0)
            If IsError(v) Then ' not found
                rLog = rLog   1
                log.Cells(rLog, "O") = .Cells(r, "K")
                log.Cells(rLog, "P") = .Cells(r, "L")
                log.Cells(rLog, "R") = .Cells(r, "M")
                n = n   1
                ar = log.Range("R2:R" & rLog)
            End If
        Next
    End With
    
    MsgBox n & " rows added"

End Sub

標籤：擅长 vba

上一篇：有沒有辦法避免在多個帶有變數的Sub中重復相同的代碼？

下一篇：VBA代碼在一臺計算機上運行，??但不在另一臺計算機上運行