[英]How to copy row to another sheet if the cell value of C matches the sheetname
因此,我提取數據,然后必須根據D列的值將行復制並粘貼到各自的工作表中。我有一個代碼可以執行此操作,但是當成千上萬行時,它的處理速度太慢。
Sub COPY_DATA()
Dim bottomD As Long
bottomD = Range("D" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("Data").Range("D2:D" & bottomD)
For Each ws In Sheets
ws.Activate
If ws.Name = c And ws.Name <> "Userform" Then
c.EntireRow.copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next ws
Next c
Worksheets("Data").Activate
End Sub
我想使復制和粘貼過程更快
這應該更快:
Sub COPY_DATA()
Dim dict As Object
Dim bottomD As Long
Dim c As Range
Dim ws As Worksheet,wb as workbook, wsData as Worksheet
Set wb = ActiveWorkbook
Set wsData = wb.worksheets("Data")
'collect the sheet names
Set dict = CreateObject("scripting.dictionary")
For Each ws In wb.Worksheets
If ws.Name <> "Userform" Then dict.Add ws.Name, True
Next ws
Application.ScreenUpdating = False
bottomD = wsData.Range("D" & Rows.Count).End(xlUp).Row
For Each c In wsData.Range("D2:D" & bottomD)
If dict.exists(c.Value) Then
c.EntireRow.Copy wb.Worksheets(c.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next c
Application.ScreenUpdating = True
wsData.Activate
End Sub
停止。 .Activating
! 完全不必要,更新UI需要花費時間。 確保對范圍的所有調用均合格。
Option Explicit '<--- Always at the top of modules!
Sub COPY_DATA()
Dim bottomD As Long
bottomD = Range("D" & Rows.Count).End(xlUp).Row
Dim c As Range
Dim ws As Worksheet
For Each c In Sheets("Data").Range("D2:D" & bottomD)
For Each ws In Sheets
With ws
If .Name = c.Value And .Name <> "Userform" Then
c.EntireRow.copy Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With
Next ws
Next c
End Sub
還要注意,我明確聲明了c.Value
而不是使用隱式/默認屬性(恰好是Value)。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.