Array Redim Preserve 将列转置为多行错误下标超出范围错误

Question

I am new to this forum and also have a bit of knowledge in VBA. I am having trouble figuring out the error behind the code that I am currently using. I am trying to convert columns into multiple rows. Sample data below: Sample Data:

Code I used for the data above:

Sub test()
    Dim wsThis As Worksheet, wsThat As Worksheet
    Dim vDB As Variant, vR() As Variant
    Dim r As Long, i As Long, n As Long
    Dim c As Integer, j As Integer, k As Integer

    Set wsThis = Sheet5: Set wsThat = Sheet8

    vdblast = wsThis.Range("A" & wsThis.Rows.Count).End(xlUp).Row
    vDB = wsThis.Range("A1:CC" & vdblast)
    vDB = wsThis.Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    n = 1
    For i = 2 To r
        For j = 8 To c
            If vDB(i, j) <> "" Then
                n = n + 1
                ReDim Preserve vR(1 To 9, 1 To n)
                For k = 1 To 8
                    vR(k, n) = vDB(i, k)
                Next k
            End If
            vR(9, n) = vDB(i, j)
        Next j
    Next i
    
    With wsThat
        .UsedRange.Clear
        .Range("a1").Resize(1, 8) = wsThis.Range("a1").Resize(1, 9).Value
        .Range("h1").Resize(1, 1) = Array("Activity Template")
        .Range("a2").Resize(n, 8) = WorksheetFunction.Transpose(vR)
    End With

End Sub

Thank you all for your help.

Answer 1

The array vDB contains all rows and cols of your Sheet5, you probably have less than 8 columns (value of k 1 to 8).

For debuging your scripts, you can use F8 to go step by step trough your code, as the yellow marker will advance, when you go over your vars with your mouse you'll be able to see their value at that moment of your script.

Answer 2

Try this:

Sub test()
    Const FIXED_COLS As Long = 7
    
    Dim wsThis As Worksheet, wsThat As Worksheet
    Dim vDB As Variant, vR() As Variant
    Dim rws As Long, cols As Long, r As Long, c As Long
    Dim k As Long, n As Long

    Set wsThis = Sheet5
    Set wsThat = Sheet8

    vDB = wsThis.Range("a1").CurrentRegion
    rws = UBound(vDB, 1)
    cols = UBound(vDB, 2)

    'size output array to max size needed: skip resizing
    ReDim vR(1 To rws * (cols - FIXED_COLS), 1 To FIXED_COLS + 1)
    
    'copy the headers
    For c = 1 To FIXED_COLS
        vR(1, c) = vDB(1, c)
    Next c
    vR(1, FIXED_COLS + 1) = "Activity Template"
    
    'copy the data
    n = 1
    For r = 2 To rws
        For c = FIXED_COLS + 1 To cols
            If Len(vDB(r, c)) > 0 Then
                n = n + 1
                For k = 1 To FIXED_COLS
                    vR(n, k) = vDB(r, k)
                Next k
                vR(n, FIXED_COLS + 1) = vDB(1, c)
            End If
        Next c
    Next r
    
    With wsThat
        .UsedRange.Clear
        'only write the used part of the output array
        .Range("a1").Resize(n, FIXED_COLS + 1) = vR
    End With

End Sub