如果有数据，则遍历单元格并将数据复制到接下来的 5 个单元格答案

【问题标题】：loop through cells and copy data to the next 5 cells if there is data如果有数据，则遍历单元格并将数据复制到接下来的 5 个单元格
【发布时间】：2015-10-06 20:23:27
【问题描述】：

下午好，

我有一个工作表，我需要一个宏从 D1 复制值并将其粘贴到接下来的 5 个单元格（粘贴到 E1:I1），然后如果下一个单元格有数据 (J1) 复制并粘贴它到接下来的五个单元格等，直到下一个单元格为空白（问题是每次此电子表格都有不同的列数）。我确实尝试使用宏记录器来执行此操作，但我必须每次设置要从中复制数据的单元格以及将它们粘贴到的单元格。必须有比这更简单的方法，任何帮助将不胜感激。 Range("D1").Select Selection.Copy Range("E1:I1").Select ActiveSheet.Paste Range("J1").Select Application.CutCopyMode = False Selection.Copy Range("K1").Select ActiveWindow.SmallScroll ToRight:=10 Range("K1:O1").Select ActiveSheet.Paste Range("P1").Select Application.CutCopyMode = False Selection.Copy Range("Q1:U1").Select ActiveSheet.Paste Range("V1").Select Application.CutCopyMode = False Selection.Copy ActiveWindow.SmallScroll ToRight:=12 Range("W1").Select ActiveSheet.Paste Range("X1:AA1").Select ActiveSheet.Paste Range("AB1").Select Application.CutCopyMode = False Selection.Copy Range("AC1:AG1").Select ActiveSheet.Paste ActiveWindow.SmallScroll ToRight:=8 Range("AH1").Select Application.CutCopyMode = False Selection.Copy Range("AI1:AM1").Select ActiveSheet.Paste Range("AN1").Select Application.CutCopyMode = False Selection.Copy Range("AO1:AS1").Select ActiveSheet.Paste

【问题讨论】：

标签： vba excel

【解决方案1】：

考虑以下情况，首先在电子表格中查找最后一列，并使用 Cells(r, c) 参考编号每 5 列迭代一次：

Sub CopyNextFive()

    LastColumn = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column

    For i = 4 To LastColumn Step 6
        Cells(1, i).Copy
        Range(Cells(1, i + 1), Cells(1, i + 5)).PasteSpecial xlPasteAll            
    Next i        
    Application.CutCopyMode = False       

End Sub

【讨论】：

【解决方案2】：

我会通过使用 RC 表示法和循环这样的东西来做到这一点：

dim myValue
dim c as integer
dim x as integer

c=4 'Start in column D
myValue = cells(1,c).value 'Row 1 of column D
while myValue <> ""
    for x = 1 to 5
        cells(1,c+x).value=myValue
    next x
    c=c+x+1 'To give us the 10th column: J
    myValue = cells(1,c).value
wend

【讨论】：

【解决方案3】：

Sub mySub()
    Dim src As Range: Set src = ActiveSheet.Range("D1")
    Dim dest As Range: Set dest = ActiveSheet.Range("E1:I1")
    Do Until Trim(src.Text) = vbNullString
        src.Copy dest
        Set src = src.Offset(, 6): Set dest = dest.Offset(, 6)
    Loop
End Sub

【讨论】：

非常感谢 ASH，您的代码也能完美运行

【解决方案4】：

您需要运行某种形式的循环。有几种类型：For ... Next、Do Until ... 等。阅读它们 (http://www.excelfunctions.net/VBA-Loops.html)，您会发现它们为您提供了极大的多功能性。

在您的情况下，许多解决方案之一可能如下：

' Adjust these values to suit
Const SHEET_NAME As String = "Sheet1" 'name of sheet
Const START_COLUMN As String = "D" 'column letter where routine starts
Const ROW_NUM As Long = 1 'row number of your data
Const COPY_SIZE As Integer = 5 'number of columns to copy the data
Dim rng As Range

' The looping routine
Set rng = ThisWorkbook.Worksheets(SHEET_NAME).Cells(ROW_NUM, START_COLUMN)
Do Until IsEmpty(rng)
    rng.Offset(, 1).Resize(, COPY_SIZE) = rng.Value2
    Set rng = rng.Offset(, COPY_SIZE + 1)
Loop

【讨论】：