I am trying to create a macro that loops a copy/paste of items in (Column A) of my "Backend" worksheet based on a single cell's value (B2) onto my "Backend 2" Worksheet. To give some context, I have forecast data on building floors and trying to reformat my spreadsheet so that Tableau will read the dates as "dimensions." In order to accomplish this I would need a macro that would copy/paste my 83 floors of data 15 times for the 15 months in my forecast. I would also like the reference cell (B2) so that I can add months to the forecast if needed. Thanks!
Copy From:
Paste to:
The current answer allows me to copy one value type "floor," but I was wondering if I could run a macro that would copy/paste an entire row based on the copy amount. Please refer to the example below. I have 3 unique teams on sheet 1 that I want copied four times based on the cell L2 on sheet 2.
Before (Sheet 1)
After (Sheet 2)
Based on my test ,worded code resembles the following. Modify the soucreSheet and targetWorksheet to yours :
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
This should work for you:
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
Alright, this should copy down the entire row :)
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
This sub is used by both to see if the sheet "Migration Plan Data Extract" already exists
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.