Excel VBA - 遍历范围并复制每个单元格 9 次

Question

我有一个包含如下数据的电子表格：

   G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD ... etc. 
2  1
3  2
4  4 8 12 16 20 24 28 32 36 40
5  8 16 24 32 40

即G2 = 1, G3 = 1 ... M4 = 28 以此类推...

我需要帮助的是通过这个范围，当人们在需要更改内容时将数据输入到这个范围内时，它可能是动态的。我需要遍历行和列，对于每个具有值的单元格，我需要将其粘贴到 D 列的不同工作表中，每个单元格 9 次。

也就是说，在第二张纸上，上面的数据会变成：

Column
  D
  1
  1
  1
  1
  1
  1
  1
  1
  1
  2
  2
  2
  2
  2
  2
  2
  2
  2
  4
  4
  .. etc... 

如何遍历每一行，然后是每一列，然后对于每个具有值的单元格，将其复制 9 次到另一张纸上的 D 列中，然后对于具有值的下一个单元格，将其复制到以下内容被粘贴了等等？

Answer 1

试试下面的。它假定您要逐列遍历该列中所有填充的单元格，重复该值 9 次。

Option Explicit

Public Sub OutputRepeatedValues()

    Dim arr()
    Const DELIMITER As String = ","
    Const NUMOFTIMES As Long = 9
    With ThisWorkbook.Worksheets("Sheet1")
        arr = .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)).Value
    End With

    Dim i As Long, j As Long, output As String

    For i = LBound(arr, 2) To UBound(arr, 2)     '<== iterate rows with a column, column by column
        For j = LBound(arr, 1) To UBound(arr, 1)
            If Not IsEmpty(arr(j, i)) Then output = output & Replicate(arr(j, i), NUMOFTIMES, DELIMITER)
        Next j
    Next i

    output = Left$(output, Len(output) - 1)

    ThisWorkbook.Worksheets("Sheet2").Range("B1").Resize(Len(output), 1) = Application.WorksheetFunction.Transpose(Split(output, DELIMITER))

End Sub

'Adapted from @this  https://codereview.stackexchange.com/questions/159080/string-repeat-function-in-vba?utm_medium=organic&utm_source=google_rich_qa&utm_campaign=google_rich_qa
Public Function Replicate(ByVal RepeatString As String, ByVal NUMOFTIMES As Long, Optional ByVal DELIMITER As String = ",")
    Dim s As String, c As Long, l As Long, i As Long
    l = Len(RepeatString) + 1
    c = l * NUMOFTIMES
    s = Space$(c)

    For i = 1 To c Step l
        Mid(s, i, l) = RepeatString & DELIMITER
    Next i

    Replicate = s
End Function

注意事项：

1. 测试数据集布局如下图

1. 我假设您希望使用G2 的任何数据或右侧的数据，包括G2。为了做到这一点，我使用SpecialCells(xlLastCell) 来查找最后使用的单元格。然后我用.Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)) 构造一个范围，在本例中为$G$2:$Q$5，并将其读入一个数组。
2. 假设您确实在移动到下一列之前使用一列迭代行，如您的问题中所述。我连接填充的单元格值，同时调用 4) 中描述的 Replicate 函数。
3. 我已经劫持并改编了@this 的一个高性能函数来处理字符串重复。我为分隔符添加了一个可选参数。添加了一个分隔符，以便我稍后可以将结果拆分到目标工作表中的各个单元格中。
4. 我在分隔符上拆分字符串 output，这会创建一个包含重复值的数组，我将其转置，因此我可以写出目标表中的列。

示例输出：

编辑：

如果您想循环使用行，然后是列，请使用上述函数：

Public Sub OutputRepeatedValues()

    Dim arr()
    Const DELIMITER As String = ","
    Const NUMOFTIMES As Long = 9
    With ThisWorkbook.Worksheets("Sheet1")
        arr = .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)).Value
    End With

    Dim i As Long, j As Long, output As String

    For i = LBound(arr, 1) To UBound(arr, 1)     '<== iterate rows with a column, column by column
        For j = LBound(arr, 2) To UBound(arr, 2)
            If Not IsEmpty(arr(i, j)) Then output = output & Replicate(arr(i, j), NUMOFTIMES, DELIMITER)
        Next j
    Next i

    output = Left$(output, Len(output) - 1)

    ThisWorkbook.Worksheets("Sheet2").Range("B1").Resize(Len(output), 1) = Application.WorksheetFunction.Transpose(Split(output, DELIMITER))

End Sub

Answer 2

我的 vba 生锈了，但我认为这段（伪）代码可能会对您有所帮助。

def last_row as integer, last_col as integer, row as integer, col as integer, target as integer
'I like something like this to get the value but you have to know the largest column: Cells(Rows.Count, col_to_check).End(xlUp).Row

target = 1

for col = 7 to last_col '7 = G
  for row = 2 to last_row
    if(Not IsEmpty(Cells(row,col)) then
      Range(Cells(target*9-8, 4), Cells(target*9, 4))= Cells(row,col)
      target = target +1
    end
  next row
next col

这将遍历所有列和行，检查是否有值并将其复制到 9 个单元格范围，然后迭代目标，使其指向接下来的 9 个单元格。