我正在嘗試從多個作業表中復制資料并將其粘貼到 Sheet1 中。結果將其粘貼到 Sheet1 中，但每次都粘貼到同一行，而不是之前復制的資料的下一行。這是我的代碼。任何幫助都非常感謝。謝謝！
Sub LoopCopySheetsData()
Dim i As Integer
Dim wb As Workbook
Dim totalWS As Long
Set wb = ActiveWorkbook
'totalWS = wb.Sheets.Count
totalWS = 4
For i = 2 To totalWS 'Start of the VBA loop
If i < totalWS 1 Then
Sheets(i).Select
With wb.Sheets(i)
Set findHeadRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues)
End With
headRow = findHeadRow.Row
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Range("A" & headRow 1 & ":A" & lastRow).Copy
Range("A1").Activate
With wb.Sheets("Sheet1")
lastRowMaster = Cells(Rows.Count, "D").End(xlUp).Row
Sheets("Sheet1").Range("D" & lastRowMaster 1).PasteSpecial xlPasteValues
End With
End If
Next i
End Sub
uj5u.com熱心網友回復：
從多個作業表復制列
- 如果標題單元格 (
Data) 包含公式，則必須使用xlValues代替xlFormulas（第一次出現）。 - 調整常量部分中的值。
Option Explicit
Sub LoopCopySheetsData()
' Source
Const sCol As String = "A"
Const sHeader As String = "Data"
' Destination
Const dName As String = "Sheet1"
Const dCol As String = "D"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
Dim sws As Worksheet
Dim srg As Range ' Range
Dim shCell As Range ' Header Cell
Dim slCell As Range ' Last Cell
Dim rCount As Long ' Source/Destination Rows Count
For Each sws In wb.Worksheets
If StrComp(sws.Name, dName, vbTextCompare) <> 0 Then ' exclude 'dws'
' Find header cell and last cell.
With sws.Columns(sCol)
Set shCell = _
.Find(sHeader, .Cells(.Cells.Count), xlFormulas, xlWhole)
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
End With
If Not shCell Is Nothing Then
If Not slCell Is Nothing Then
rCount = slCell.Row - shCell.Row ' without header
If rCount > 0 Then
Set srg = shCell.Offset(1).Resize(rCount)
dfCell.Resize(rCount).Value = srg.Value ' copy
Set dfCell = dfCell.Offset(rCount) ' next
End If
End If
End If
End If
Next sws
MsgBox "Done.", vbInformation
End Sub
uj5u.com熱心網友回復：
請注意這篇文章：如何避免在 Excel VBA 中使用 Select。至于第二個答案中提到，避免任何使用ActiveWorkbook，Activate以及Select為提高效率，維護和可讀性。
相反，明確限定所有Workbook，Worksheet，Cells，Range，和其他物件。事實上，考慮范圍分配并避免復制和粘貼的需要：
Sub LoopCopySheetsData()
Dim i As Integer, totalWS As Integer
Dim headRow As Long, lastRow As Long, headRowMaster As Long, lastRowMaster As Long
'totalWS = ThisWorkbook.Sheets.Count
totalWS = 4
For i = 2 To totalWS
If i < (totalWS 1) Then
With ThisWorkbook.Sheets(i)
headRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues).Row
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ThisWorkbook.Sheets("Sheet1")
headRowMaster = .Cells(.Rows.Count, "D").End(xlUp).Row
lastRowMaster = headRowMaster (lastRow - headRow)
' ASSIGN VALUES BY RANGE
.Range("D" & headRowMaster 1 & ":D" & lastRowMaster).Value = _
ThisWorkbook.Sheets(i).Range("A" & headRow 1 & ":A" & lastRow).Value
End With
End If
Next i
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/401793.html