[英]Copy/Paste Item onto another sheet based on a single cell value
我正在嘗試創建一個宏,該宏根據單個單元格的值 (B2) 將“后端”工作表(A 列)中的項目的副本/粘貼循環到我的“后端 2”工作表上。 為了提供一些背景信息,我有關於建築樓層的預測數據,並嘗試重新格式化我的電子表格,以便 Tableau 將日期讀取為“尺寸”。 為了實現這一點,我需要一個宏來在我的預測中在 15 個月內復制/粘貼我的 83 層數據 15 次。 我還想要參考單元格 (B2),以便我可以在需要時將月份添加到預測中。 謝謝!
復制自:
粘貼到:
當前的答案允許我復制一個值類型“floor”,但我想知道我是否可以運行一個宏來根據復制量復制/粘貼整行。 請參考下面的例子。 我在工作表 1 上有 3 個獨特的團隊,我想根據工作表 2 上的單元格 L2 將它們復制四次。
之前(表 1)
之后(表 2)
根據我的測試,措辭代碼類似於以下內容。 將 soucreSheet 和 targetWorksheet 修改為您的:
Sub Test11()
Dim rowCount As Long
Dim sourceSheet As Worksheet
Dim targetWorksheet As Worksheet
Dim copyTimes As Integer
Set sourceSheet = Worksheets("Sheet11")
Set targetWorksheet = Worksheets("Sheet12")
rowCount = targetWorksheet.Cells(Rows.Count, 1).End(xlUp).row
copyTimes = CInt(sourceSheet.Cells(2, 2).Value)
For i = 2 To sourceSheet.UsedRange.Rows.Count
MsgBox sourceSheet.Cells(i, 1).Value
sourceSheet.Cells(i, 1).Copy
For j = 1 To copyTimes
targetWorksheet.Activate
targetWorksheet.Cells(rowCount + 1, 1).Select
targetWorksheet.Paste
rowCount = rowCount + 1
Next
sourceSheet.Activate
Next
Application.CutCopyMode = False
End Sub
這應該適合你:
Sub floors()
Dim ws1 As Worksheet
Set ws1 = sheets("Bcknd")
Dim ws2 As Worksheet
If Not sheetExists("Migration Plan Data Extract") Then
sheets.Add After:=ws1
Set ws2 = sheets(ws1.index + 1)
ws2.name = "Migration Plan Data Extract"
Else
Set ws2 = sheets("Migration Plan Data Extract")
End If
If Len(ws1.Range("B2").Value2) > 0 And IsNumeric(ws1.Range("B2").Value2) Then
ws2.Range("A1").Value2 = ws1.Range("A1").Value2
Dim vals As Variant
vals = ws1.Range("A2:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).Value
Dim i As Long
Dim j As Long: j = 1
For i = 1 To ws1.Range("B2").Value2 * UBound(vals)
ws2.Range("A" & i + 1).Value2 = vals(j, 1)
If i Mod ws1.Range("B2") = 0 Then
j = j + 1
End If
Next i
End If
End Sub
好的,這應該復制整行:)
Sub floors2()
Dim ws1 As Worksheet
Set ws1 = sheets("Bcknd")
If Len(ws1.Range("L2")) > 0 And IsNumeric(ws1.Range("L2").Value2) Then
Dim ws2 As Worksheet
If Not sheetExists("Migration Plan Data Extract") Then
sheets.Add After:=ws1
Set ws2 = sheets(ws1.index + 1)
ws2.name = "Migration Plan Data Extract"
Else
Set ws2 = sheets("Migration Plan Data Extract")
End If
ws1.Range("A1:J1").copy Destination:=ws2.Range("A1:J1")
Dim lastRow As Long
lastRow = ws1.Range("A" & rows.count).End(xlUp).row
Dim rng As Range
Set rng = ws1.Range("A2:J" & lastRow)
Dim currentRow As Long: currentRow = 2
Dim i As Long
Dim j As Long
For i = 1 To rng.rows.count
For j = 1 To ws1.Range("L2").Value2
rng.rows(i).copy Destination:=ws2.Range("A" & currentRow)
currentRow = currentRow + 1
Next j
Next i
End If
End Sub
兩者都使用此子項來查看“遷移計划數據提取”表是否已存在
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
Dim sheet As Worksheet
For Each sheet In Worksheets
If sheetToFind = sheet.name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.