Question

这是我使用Excel-VBA的第一个项目。我已经弄清楚了如何使用VBA代码来完成我想要的大部分工作。我现在正尝试将数据复制到新的单元格，然后我想复制一个范围，但不复制下来新单元格的数据并将其留空。我只能将复制的数据保留在正确的位置，而不能随范围副本一起向下移动。我不知道是否有可能做我想做的事，或者我只是不知道怎么做。任何帮助将不胜感激！

Sub AddHeader()
    Range("CA1").Formula = "Stay Date"
End Sub

=====================================

Sub CellCopy()
    Range("H2:H4000").Copy Range("CA2")
End Sub

=====================================

Sub CopyData()
    Dim xRow As Long
    Dim VInSertNum As Variant
    xRow = 1
    Application.ScreenUpdating = False
    Do While (Cells(xRow, "A") <> "")
        VInSertNum = Cells(xRow, "P")
        If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
           Range(Cells(xRow, "A"), Cells(xRow, "BZ")).Copy
           Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "BZ")).Select
           Selection.Insert Shift:=xlDown
           xRow = xRow + VInSertNum - 1
        End If
        xRow = xRow + 1
    Loop
    Application.ScreenUpdating = False
End Sub

=====================================

Sub RunAllMacros()
    AddHeader
    CellCopy
    CopyData
End Sub

Answer 1

您的问题尚不完全清楚，但如果我理解正确，您想：

重复工作表中的每一行n次（其中从工作表本身读取n，每一行都有自己的n值）。
您希望排除某些重复的列。

我要补充一点：

以相反的顺序循环可能更好（这样，行插入不会影响迭代器/变量，从而跟踪循环进度）。
您是否考虑过复制整行（Range.EntireRow），然后使用Range.Clear清除那些您不想重复的列？
提供输入示例和预期输出总是很好的。否则，响应者很难验证自己的答案。

以下代码：

Option Explicit

Private Sub AddHeader(ByVal someSheet As Worksheet)
    someSheet.Range("CA1").Formula = "Stay Date"
End Sub

Private Sub CellCopy(ByVal someSheet As Worksheet)
    someSheet.Range("H2:H4000").Copy someSheet.Range("CA2")
End Sub

Private Sub RunAllMacros()

    Dim sheetToModify As Worksheet
    Set sheetToModify = ActiveSheet ' Better to replace with something like ThisWorkbook.Worksheets("Sheet1")

    AddHeader sheetToModify
    CellCopy sheetToModify
    CopyData sheetToModify
End Sub

Private Sub CopyData(ByVal someSheet As Worksheet)

    Dim lastRow As Long
    lastRow = someSheet.Cells(someSheet.Rows.Count, "A").End(xlUp).Row

    Dim rowIndex As Long
    For rowIndex = lastRow To 2 Step -1 ' Presume you want to skip headers?

        Dim numberOfTimesToRepeatRow As Variant
        numberOfTimesToRepeatRow = someSheet.Cells(rowIndex, "P") ' Will need to -1 as count includes the row being copied.

        If IsGreaterThanOne(numberOfTimesToRepeatRow) Then
            With someSheet.Range("A" & rowIndex, "CA" & rowIndex)
                .Copy
                .Offset(1).Resize(numberOfTimesToRepeatRow - 1).Insert Shift:=xlDown

                ' Have to repeat/re-evaluate (cannot use With or
                ' object reference since rows have been inserted)
                .Offset(1).Resize(numberOfTimesToRepeatRow - 1).Columns("CA").Clear
            End With
        End If
    Next rowIndex

    Application.CutCopyMode = False

End Sub

Private Function IsGreaterThanOne(ByVal someValue As Variant)
    ' Dedicated function to reduce indentation in caller.
    ' Returns True if value is numeric AND greater than 1 (else
    ' False).
    ' Separate IF statements since no short-circuit
    ' evaluation -- meaning non-numeric values could otherwise
    ' cause type mismatch error.
    If IsNumeric(someValue) Then
        If someValue > 1 Then
            IsGreaterThanOne = True
        End If
    End If
End Function

以上代码仅将原始行的值保留在CA列中，而不是新插入的行。换句话说，新插入的行的CA列中有空白。

希望如此，并为您提供一些实现方法的想法。如果我误会了，您可以告诉我。

有没有办法复制范围并在循环中排除单元格/列？

1 个答案: