时间戳

首页 > 解决方案 > 如何将一列数据变成 8x12 的网格？

excel - 如何将一列数据变成 8x12 的网格？

问题描述

我正在尝试将 1 列中的值放入 8x12 网格中。

第一个值从网格的左上角开始，向右移动 12 个单元格，然后从起始单元格偏移 1 行，并让数据继续以这种格式填充单元格。

我正在尝试替换

roneWS.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13"))
roneWS.Range("C7:N7") = Application.Transpose(ptWS.Range("B14:B25"))
roneWS.Range("C8:N8") = Application.Transpose(ptWS.Range("B26:B37"))
roneWS.Range("C9:N9") = Application.Transpose(ptWS.Range("B38:B49"))
roneWS.Range("C10:N10") = Application.Transpose(ptWS.Range("B50:B61"))
roneWS.Range("C11:N11") = Application.Transpose(ptWS.Range("B62:B73"))
roneWS.Range("C12:N12") = Application.Transpose(ptWS.Range("B74:B85"))
roneWS.Range("C13:N13") = Application.Transpose(ptWS.Range("B86:B97"))

带有数组/循环。

我想出了：

Dim ptWS As Worksheet, roneWS As Worksheet, rtwoWS As Worksheet, rthreeWS As Worksheet, rfourWS As Worksheet
Dim ptRng As Range, destRng As Range
Dim i As Integer
Dim ptArr() As Variant

Set ptWS = ThisWorkbook.Worksheets("PT")
Set roneWS = ThisWorkbook.Worksheets("WS1")
Set rtwoWS = ThisWorkbook.Worksheets("WS2")
Set rthreeWS = ThisWorkbook.Worksheets("WS3")
Set rfourWS = ThisWorkbook.Worksheets("WS4")


i = 4
Set ptRng = ptWS.Range("B4:B97")            'data that needs to be moved to other worksheets B4:B97 = 1st WS, C4:C97 = 2nd WS, D4:D97 = 3rd WS, E4:E97 = 4th WS
Set destRng = roneWS.Range("E6")            'destination range for WS1-WS4 starts at E6
ptArr = ptRng.Value                         'setting all values for the WS1 to ptArr

For i = LBound(ptArr) To UBound(ptArr)      

    If ptArr(i, 1) = ptWS.Cells(14, 2) Then             'move my way across the columns until I hit Col O then, offset back to Col C and repeat until the end (N13) is reached
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    ElseIf ptArr(i, 1) = ptWS.Cells(26, 2) Then
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    ElseIf ptArr(i, 1) = ptWS.Cells(38, 2) Then
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    ElseIf ptArr(i, 1) = ptWS.Cells(50, 2) Then
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    ElseIf ptArr(i, 1) = ptWS.Cells(62, 2) Then
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    ElseIf ptArr(i, 1) = ptWS.Cells(74, 2) Then
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    ElseIf ptArr(i, 1) = ptWS.Cells(86, 2) Then
        Set destRng = destRng.Offset(1, -12)
        destRng = ptArr(i, 1)
        Set destRng = destRng.Offset(0, 1)
    Else: destRng = ptArr(i, 1)
    Set destRng = destRng.Offset(0, 1)
    End If

Next i

它给了我想要的 WS1。但是，我必须对其他 3 个工作表重复此操作。

对于其他 3 个工作表，总范围与上面发布的相同，只是偏移了 1 列。

      WS1 = ptWS.Range("B4:B97")
   
      WS2 = ptWS.Range("C4:C97")

      WS3 = ptWS.Range("D4:D97")

      WS4 = ptWS.Range("E4:E97")

所有 4 个工作表上的目标起点都是相同的Range(E6")。

一旦设置了 WS1 上的所有单元格，如何在工作表中添加一个循环，同时也将列从 ptWS 偏移 1。我想知道这是否可以在不复制/粘贴现有​​数组代码 3 次并且只更改范围的情况下完成。

我通过使用一系列 Do Until 循环遍历 ptWS 上的数据获得了相同的结果，但最终遇到了同样的问题。

标签： excelvba

解决方案

这是一种方法：

Sub Tester()
    Dim i As Long
    
    For i = 1 To 4
        ColToMatrix ThisWorkbook.Worksheets("PT").Range("B4:B97").Offset(0, i - 1), _
                    ThisWorkbook.Worksheets("WS" & i).Range("C6")
    Next i

End Sub

'pass in the column to be mapped and the top-left destination cell for the matrix
Sub ColToMatrix(rngCol As Range, rngTL As Range)
    Dim arr, mtx(1 To 8, 1 To 12), i As Long, r As Long, c As Long, n As Long
    arr = rngCol.Value
    For i = 1 To UBound(arr, 1)
        n = i + 2 'account for starting 3 cells in
        r = 1 + ((n - 1) \ 12)
        c = ((n - 1) Mod 12) + 1
        mtx(r, c) = arr(i, 1)
    Next i
    rngTL.Resize(8, 12).Value = mtx
End Sub

推荐阅读