我试图创建一个宏,该宏基于单个单元格的值(B2)将“后端”工作表(A列)中项目的复制/粘贴循环到“后端2”工作表中。为了提供一些背景信息,我对建筑物地板上的数据进行了预测,并尝试重新格式化电子表格,以便Tableau将日期读取为“尺寸”。为了实现这一目标,我需要一个宏,该宏将在我的预测中的15个月内将83层数据复制/粘贴15次。我也希望参考单元格(B2),以便在需要时可以将几个月增加到预测中。谢谢!
复制来源:
粘贴至:
当前答案允许我复制一个值类型“ floor”,但是我想知道是否可以运行一个宏,该宏将根据复制量复制/粘贴整行。请参考下面的例子。我在工作表1上有3个独特的团队,我希望根据工作表2上的单元格L2复制四次。
之前(表1)
之后(第2页)
答案 0 :(得分:0)
根据我的测试,措辞类似于以下代码。 将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
答案 1 :(得分:0)
这应该对您有用:
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