我對 VBA 很陌生，我想知道如何僅復制作業表的白色單元格并將它們粘貼到相同的位置，但粘貼到另一個作業簿。
具體來說，我有兩個帶有多個作業表的作業簿，它們是相同的，但是源作業簿填充了一些白色單元格，而目標作業簿有這些單元格是空的。我想將值從源白色單元格傳輸到目標白色單元格。另外，如果可能的話，我想用“0”填充空白的單元格。
我發現了一些代碼可以將所有彩色單元格復制到另一個 Excel 作業表，但它們不會轉移到另一個作業簿和確切的位置。
Sub CopyHighlightedTransactions()
Dim TransIDField As Range
Dim TransIDCell As Range
Dim ATransWS As Worksheet
Dim HTransWS As Worksheet
Set ATransWS = Worksheets("All Transactions")
Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
Set HTransWS = Worksheets("Highlighted Transactions")
For Each TransIDCell In TransIDField
If TransIDCell.Interior.Color = RGB(255, 0, 0) Then
TransIDCell.Resize(1, 10).Copy Destination:= _
HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next TransIDCell
HTransWS.Columns.AutoFit
End Sub
先感謝您。
uj5u.com熱心網友回復：
如果上面的影片是你的意思（如果我理解正確的話），也許你想試試下面的子：
Sub test()
Dim wbS As Worksheet: Dim wbT As Worksheet
Dim rgData As Range: Dim c As Range
Application.ScreenUpdating = False
'prepare variable for the workbook and sheet of the source and target
Set wbS = Workbooks("Source.xlsm").Sheets("Sheet1") 'change as needed
Set wbT = Workbooks("Target.xlsx").Sheets("Sheet1") 'change as needed
'the range of the data to be searched
Set rgData = wbS.Range("A1:D10") 'change as needed
'prepare the color to be searched
With Application.FindFormat
.Clear
.Interior.Color = vbWhite
End With
'start searching as c variable
Set c = rgData.Find(What:=vbNullString, SearchFormat:=True)
'loop until all cells in rgData is checked if the color is white or not
'if found white then copy the c, paste to wbT with that c address
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Copy Destination:=wbT.Range(c.Address)
Set c = rgData.Find(What:=vbNullString, after:=c, SearchFormat:=True)
Loop While c.Address <> FirstAddress
End If
End Sub
要測驗代碼，請復制您的作業簿（源和目標）。復制子，粘貼到復制的作業簿上，然后運行它。兩個作業簿都必須打開。如果您的資料范圍很大，則需要一些時間，因為代碼將檢查 rgData 中所有具有白色的單元格。
源作業簿填充了一些白色單元格
請記住，代碼正在尋找填充白色的單元格。
我很好奇下面的 test2 sub 是否更快，因為沒有回圈。
Sub test2()
Dim rgW_orig As Range: Dim rgDest As Range
Dim rgW As Range: Dim rgX As Range
Dim rgBlank As range
Application.ScreenUpdating = False
Set rgW_orig = Sheets(1).Range("A1:D10")
Set rgDest = Workbooks("Target.xlsx").Sheets(1).Range(rgW_orig.Address)
With Application.FindFormat.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Workbooks.Add
Set rgW = ActiveSheet.Range(rgW_orig.Address)
rgW_orig.Copy Destination:=rgW
With rgW
.Replace What:="", Replacement:=True, LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=False
Set rgX = .SpecialCells(xlConstants, xlLogical)
End With
rgW.Value = "": rgX.Value = 1
set rgBlank = rgW.SpecialCells(xlBlanks)
rgW.Value = rgW_orig.Value
rgBlank.ClearContents
rgW.Copy
rgDest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Close False
End Sub
test2 宏使用新的作業簿作為助手，并假設 Source.xlsm（宏所在的位置）中的資料范圍與 Target.xlsx 中的資料范圍相同。
首先，它在新作業簿中設定一個與 rgW_orig 相同地址的范圍作為 rgW 變數。然后它復制 rgW_orig 并將其粘貼到 rgW
然后在新作業簿（助手作業簿）中：
它獲取所有填充白色的單元格（通過用 TRUE 布林值替換白色單元格），將其設定為 rgX 變數。
接下來，它用空白填充整個范圍（rgW），并用 1 填充 rgX，然后將所有沒有值（空白）的單元格作為 rgBlank 變數。
它再次將 rgW_orig 復制到 rgW 中，然后清除 rgBlank 的內容。現在在 rgW 中的這個幫助作業簿中，具有值的單元格只有白色的單元格，其余的都是空白的。
最后它復制 rgW，將“skip blank”粘貼到 rgDest 中，然后關閉助手作業簿而不保存。
仍然不確定這個 test2 sub 是否比以前的 sub 快。
轉載請註明出處，本文鏈接：https://www.uj5u.com/caozuo/519621.html
標籤：擅长vba