[英]VBA Match Cell Range to Worksheet Name and copy/paste to respective worksheet
[英]VBA Copy and Paste Data with Matching Worksheet Name
我是 VBA 的新手,所以我不是很好。 我有一個工作簿,其中包含工作表“摘要”(所有數據都被合並,如圖 1 所示)、“8”、“9”、“10”。 我想從“摘要”復制數據,條件是如果 A 列中的單元格包含工作表名稱(8,9 或 10),則該單元格的行和列 C 到 E 將粘貼到具有匹配名稱的工作表中(如圖 2)。 粘貼的數據將偏移到第 7 行,每個數據將增加一個空格。 例如,“摘要”中 A 列第 2 到 6 行的單元格包含“8”,因此 C 到 E 列第 2 到 6 行將被復制並粘貼到工作表“8”。 鏈接到我的宏文件: https://drive.google.com/file/d/18UalCvxIXuP6imVWZsWLRZPghMqogZp8/view?usp=sharing
我有 ff 代碼,但它不會進行偏移和增量:
Sub Copy_Data()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Double
Sheets("Summary").Activate
Dim lastrow As Long
lastrow = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Dim ans As String
For i = 2 To lastrow
ans = Cells(i, "A").Value
Lastrowa = Sheets(ans).Cells(Rows.Count, "C").End(xlUp).Row
Sheets("Summary").Rows(i).Columns("C:E").Copy
Sheets(ans).Rows(Lastrowa + 1).Columns("C:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
Application.ScreenUpdating = True
End Sub
如果非常感謝!!
Sub Copy_Data()
Dim lastRow As Long, offsetRow As Long, i As Long, No As String, NOSheet As Worksheet, auxRow As Long, summarySheet As Worksheet
Set summarySheet = Worksheets("Summary")
lastRow = summarySheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
offsetRow = 7
For i = 2 To lastRow
No = Cells(i, "A")
Set NOSheet = Worksheets(No)
auxRow = NOSheet.Columns("C").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If auxRow > 1 Then auxRow = auxRow + 2
If auxRow = 1 Then auxRow = offsetRow
NOSheet.Cells(auxRow, "C") = summarySheet.Cells(i, "C")
NOSheet.Cells(auxRow, "D") = summarySheet.Cells(i, "D")
NOSheet.Cells(auxRow, "E") = summarySheet.Cells(i, "E")
Next i
End Sub
Source Worksheet
數據是連續的,並且從單元格A1
( CurrentRegion
) 開始。Option Explicit
Sub CopyData()
Const sName As String = "Summary" ' Source Worksheet Name
Const sdCol As String = "A" ' Destination Worksheet Name Column
Const sCols As String = "C:E" ' Source Copy Columns
Const sFirst As Long = 2 ' Source First Row
Const dCol As String = "C" ' Destination First (Paste) Column
Const dFirst As Long = 7 ' Destination First Row
Const drOffset As Long = 2 ' Destination Row Offset
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim sLast As Long: sLast = srg.Rows.Count ' Source Last Row
Dim cCount As Long: cCount = sws.Columns(sCols).Columns.Count
Application.ScreenUpdating = False
Dim srrg As Range ' Source Row Range
Dim r As Long ' Source Row Counter
Dim dws As Worksheet ' Destination Worksheet
Dim drrg As Range ' Destination Row Range
Dim dCell As Range ' Destination Last Cell
Dim dName As String ' Destination Worksheet Name
For r = sFirst To sLast
dName = CStr(srg.Columns(sdCol).Rows(r).Value)
Set dws = Nothing
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Set dCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp)
If dCell.Row < dFirst Then
Set drrg = dws.Cells(dFirst, dCol).Resize(, cCount)
Else
Set drrg = dCell.Offset(drOffset).Resize(, cCount)
End If
Set srrg = srg.Columns(sCols).Rows(r)
drrg.Value = srrg.Value
'Else
' Destination Worksheet doesn't exist.
End If
Next r
Application.ScreenUpdating = True
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.