☰

需要帮助创建一个循环以某种方式复制和粘贴数据

tag-icon • tag-icon microsoft-excel vba copy-paste loopback visual-basic
需要帮助创建一个循环以某种方式复制和粘贴数据

我已经困扰这个循环三天了，最后向社区请求帮助。

我想根据 Sheet3 中的行多次将 M 列（输入表）中的每个单元格复制到 BE 列的输出表，然后继续复制 M 列（输入表）中的下一个单元格，并将其复制到已复制数据下方的 BE 列的输出表中。这应该运行到 M 列输入表中的最后一个值。以下是我面临的真实情况

我有 63 行（62 + 1 个标题），其值位于输入表的 M 列（行数不是恒定的，应该是灵活的）我想复制输入表的 M2 单元格中的值，然后复制到输出表的 BE 列中（第 1 行是标题）。此值的粘贴次数应基于 Sheet3 范围 B7 中的行数，直到最后一行填充（在本例中，我在 Sheet3 中有 4 行，因此应在输出表中粘贴 4 次该值）。然后它应该移动到输入表中的 M3 单元格，并在输出表的 BE 列中的下一个可用行中复制相同次数。

这样，它应该将输入表 M 列的最后一行复制到输出表 BE 列，次数与 Sheet3 B7 及以后的行数相同。

检查结果为 62（输入表中的单元格）* 4（表 3 B7 及以后的行）= 248（输出表中的 BE 列）

提前非常感谢您。

下面是我编写的 VBA 代码，但其中有些东西似乎不正确。

Sub Allocation()

'Raw data sheet lets us know how many times to copy, here B6 onwards down
'UBRSplit is the input sheet where we need to copy value from M2 onwards
'Working sheet is the output where the paste is required from BE2 onwards


Application.ScreenUpdating = False

Dim i As Integer
Dim r As Integer

i = Sheets("Raw Data").Range("B5").End(xlDown).Offset(1, 0).Row

For r = 2 To i

Sheets("UBRSplit").Select
    Range("M2").Select
    Selection.Copy


Sheets("Working sheet").Select
Range("BE" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial

Sheets("UBRSplit").Select
Next

End Sub

答案1

生成数据

尖端

  • （使用Option Explicit）。
  • 使用常量。
  • 使用变量，尤其是对于对象：工作簿、工作表和范围。
  • 如果您将其关闭（Application.ScreenUpdating = False），请稍后将其打开（Application.ScreenUpdating = True）。
  • 用Long代替 来Integer表示整数。
  • 如果是工作表，则使用Worksheets，而不是Sheets。限定工作表将避免在另一个工作簿处于活动状态（选定）时出现意外行为，例如ThisWorkbook.Worksheets("UBRSplit")。
  • End(xlDown)如果数据少于 2 行，可能会让您大失所望（它会“跳过”一百万行）。End(xlUp)从最底部的单元格开始是最常见的方法，但我更喜欢使用同时“允许”隐藏行的Find方法。xlFormulas
  • i是为计数器保留的。最好使用更具描述性的变量名，例如LastRow。
  • 从 1 开始数比较好。不管怎样，从 1 到 4 或从 2 到 5 都是 4 次。
  • 不要使用Select（它会减慢你的代码）。最好使用例如Sheets("UBRSplit").Range("M2").Copy和Sheets("Working sheet").Range("BE" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial。
  • Next就其本身而言是可以的，但Next r可读性更强。
  • 使用数组将大大提高性能，因为只有一次写入工作表。

我的选择

Sub GenerateData()

    ' Reps
    Const rName As String = "Raw Data"
    Const rFirst As String = "B7"
    ' Source
    Const sName As String = "UBRSplit"
    Const sFirst As String = "M2"
    ' Destination
    Const dName As String = "Working sheet"
    Const dFirst As String = "BE2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Attempt to calculate the number of reps (repetitions) ('rCount').
    Dim rCount As Long
    Dim wsrCount As Long
    With wb.Worksheets(rName).Range(rFirst)
        wsrCount = .Worksheet.Rows.Count ' for all worksheets
        Dim rlCell As Range
        Set rlCell = .Resize(wsrCount - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If rlCell Is Nothing Then
            MsgBox "No data in worksheet '" & rName & "'.", vbExclamation
            Exit Sub
        End If
        rCount = rlCell.Row - .Row + 1
    End With

    ' Attempt to create a reference to the Source Column Range ('srg').
    Dim srg As Range
    With wb.Worksheets(sName).Range(sFirst)
        Dim slCell As Range
        Set slCell = .Resize(wsrCount - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then
            MsgBox "No data in worksheet '" & sName & "'.", vbExclamation
            Exit Sub
        End If
:       Set srg = .Resize(slCell.Row - .Row + 1)
    End With
    
    ' Write the values from the Source Column Range ('srg')
    ' to the Source Data Array ('sData').
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData As Variant
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Define Destination Data Array ('dData').
    Dim drCount As Long: drCount = srCount * rCount
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
    
    ' Write the repeating ('rCount') values from the Source Data Array ('sData')
    ' to the Destination Data Array ('dData').
    Dim s As Long, r As Long, d As Long
    For s = 1 To srCount
        For r = 1 To rCount
            d = d + 1
            dData(d, 1) = sData(s, 1)
        Next r
    Next s
    
    ' Write the values from the Destination Data Array ('dData')
    ' to the Destination Column Range and clear the contents below.
    With wb.Worksheets(dName).Range(dFirst)
        .Resize(drCount) = dData
        .Resize(wsrCount - .Row - drCount + 1).Offset(drCount).ClearContents
    End With
        
    ' Inform user.
    MsgBox "Data successfully generated.", vbInformation, "Generate Data"
        
End Sub

注释过多，但可读性更强

Sub GenerateDataOverCommented()

    ' Reps
    Const rName As String = "Raw Data" ' Reps Worksheet Name
    Const rFirst As String = "B7" ' Reps First Cell Address
    ' Source
    Const sName As String = "UBRSplit" ' Source Worksheet Name
    Const sFirst As String = "M2" ' Source First Cell Address
    ' Destination
    Const dName As String = "Working sheet" ' Destination Worksheet Name
    Const dFirst As String = "BE2" ' Destination First Cell Address
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Attempt to calculate the number of reps (repetitions) ('rCount').
    Dim rws As Worksheet: Set rws = wb.Worksheets(rName)
    Dim wsrCount As Long: wsrCount = rws.Rows.Count ' for all worksheets
    Dim rfCell As Range: Set rfCell = rws.Range(rFirst)
    Dim rlCell As Range
    ' Using 'Find' in the range from the first to the bottom-most cell.
    Set rlCell = rfCell.Resize(wsrCount - rfCell.Row + 1) _
        .Find("*", , xlFormulas, , , xlPrevious)
    If rlCell Is Nothing Then
        MsgBox "No data in worksheet '" & rName & "'.", vbExclamation
        Exit Sub
    End If
    Dim rCount As Long: rCount = rlCell.Row - rfCell.Row + 1

    ' Attempt to create a reference to the Source Column Range ('srg').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
    Dim slCell As Range
    ' Using 'Find' in the range from the first to the bottom-most cell.
    Set slCell = sfCell.Resize(wsrCount - sfCell.Row + 1) _
        .Find("*", , xlFormulas, , , xlPrevious)
    If slCell Is Nothing Then
        MsgBox "No data in worksheet '" & sName & "'.", vbExclamation
        Exit Sub
    End If
    Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
    
    ' Write the values from the Source Column Range ('srg')
    ' to the Source Data Array ('sData').
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData As Variant
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Define Destination Data Array ('dData').
    Dim drCount As Long: drCount = srCount * rCount
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 1)
    
    ' Write the repeating ('rCount') values from the Source Data Array ('sData')
    ' to the Destination Data Array ('dData').
    Dim s As Long, r As Long, d As Long
    For s = 1 To srCount
        For r = 1 To rCount
            d = d + 1
            dData(d, 1) = sData(s, 1)
        Next r
    Next s
    
    ' Create a reference to the Destination Column Range ('drg').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfCell.Resize(drCount)
    
    ' Write the values from the Destination Data Array ('dData')
    ' to the Destination Column Range ('drg').
    drg.Value = dData
    
    ' Create a reference to the Destination Clear Range ('dcrg'),
    ' the range from one cell below the just written Destination Column Range
    ' ('dws.Cells(dfCell.Row + drCount, dfcell.Column)')
    ' to the bottom-most cell ('dws.Cells(wsrCount, dfcell.Column)')
    ' of the Destination Column.
    Dim dcrg As Range
    Set dcrg = dfCell.Resize(wsrCount - dfCell.Row - drCount + 1) _
        .Offset(drCount)
    
    ' Clear the contents of the cells of the Destination Clear Range.
    dcrg.ClearContents
        
    ' Inform user.
    MsgBox "Data successfully generated.", vbInformation, "Generate Data"
        
End Sub

相关内容