我正在尝试创建一个宏,它根据单个单元格的值(B2)将我的“后端”工作表的(列A)中的项目的复制/粘贴循环到我的“后端2”工作表上。为了给出一些上下文,我预测了建筑楼层的数据,并尝试重新格式化我的电子表格,以便Tableau将日期读作“尺寸”。为了实现这一点,我需要一个宏,它可以在我预测的15个月中复制/粘贴我的83层数据15次。我还想要参考单元格(B2),以便我可以根据需要在预测中添加几个月。谢谢!
复制自:
这样做:
当前的答案允许我复制一个值类型“floor”,但我想知道我是否可以运行一个宏,根据复制量复制/粘贴整行。请参考下面的示例。我在表1中有3个独特的团队,我希望根据表2中的单元格L2复制四次。
之前(第1页)
之后(表2)
这应该适合你:
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
根据我的测试,措辞代码类似于以下内容。将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