![](/img/trans.png)
[英]Copy (only value and not formula) range of cells to another sheet in same file
[英]VBA to copy a range of cells only if no match is found in another sheet
僅當新工作表中不存在該行時,才嘗試將以下變量范圍內的數據復制到新工作表中。
我正在使用輔助列,因為只有在未找到兩列中的條件時才應復制單元格。
(場景計算表)
(場景儀表盤)
如果代碼實際有效,則預期輸出:
僅添加了 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
提前致謝 :)
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文件。
我將您的范圍轉換為表格,因為它更具動態性。
我創建了一個新的輔助列“ 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
您的代碼所需的更正是
'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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.