Announcement

Collapse
No announcement yet.

VBA turn columns into rows

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • VBA turn columns into rows



    Good afternoon everybody.

    I have a very large spreadsheet which contains around 2000 rows, the first six columns of which are master data. Thereafter, there is a number of six-column blocks that contain "sets" of transactional data. All rows have at least one six-column block, some have more, up to a maximum of 87 blocks (meaning 6*87 columns). Beyond the point at which any given row "runs out" of data, it's completely empty.

    What I need to do is this: for any row which has more than one set of transactional data (i.e. any row with data in column M or beyond), I need to cut the data out, in six-column blocks, and paste that into new rows beneath the first set of transactional data.

    So, we'd go from this:
    A B C D E F G H I J K L M N O P Q R S T U V W X
    1 M1 M2 M3 M4 M5 M6 T11 T12 T13 T14 T15 T16 T21 T22 T23 T24 T25 T26 T31 T32 T33 T34 T35 T36
    2 M1 M2 M3 M4 M5 M6 T11 T12 T13 T14 T15 T16
    3 M1 M2 M3 M4 M5 M6 T11 T12 T13 T14 T15 T16 T21 T22 T23 T24 T25 T26
    ... to this:
    A B C D E F G H I J K L
    1 M1 M2 M3 M4 M5 M6 T11 T12 T13 T14 T15 T16
    2 T21 T22 T23 T24 T25 T26
    3 T31 T32 T33 T34 T35 T36
    4 M1 M2 M3 M4 M5 M6 T11 T12 T13 T14 T15 T16
    5 M1 M2 M3 M4 M5 M6 T11 T12 T13 T14 T15 T16
    6 T21 T22 T23 T24 T25 T26

    As you can see, the master data doesn't need to be copied down into the new rows, and once the transactional data "runs out" for any given line, I can stop inserting rows and cutting the data into them (so there won't be any empty rows in the final data).

    Can anybody help me? I suspect this isn't terribly hard, but even though I think I understand the logic required I can't convert into into a macro.

    My thanks to anybody who has taken the time and trouble to read this, and in advance to anybody who has a crack at it.

    Cheers

    Jeff

  • #2
    Try this. Run the macro with the data sheet active
    Code:
    Sub RearrangeData()
        Dim x, y(), z, i As Long, ii As Long, iii As Long, iv As Long, v As Long
        
        With ActiveSheet.Cells(1).CurrentRegion
            x = .Value2
            For i = 1 To UBound(x, 1)
                iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
                For ii = 1 To 12
                    y(ii, iii) = x(i, ii)
                Next
                iv = 13
                Do Until x(i, iv) = vbNullString
                    v = 6
                    iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
                    For ii = iv To iv + 5
                        v = v + 1
                        y(v, iii) = x(i, ii)
                    Next
                    iv = iv + 6
                    If iv >= UBound(x, 2) Then Exit Do
                Loop
            Next
            
            ReDim z(1 To iii, 1 To 12)
            For i = 1 To iii
                For ii = 1 To 12
                    z(i, ii) = y(ii, i)
                Next
            Next
            .Clear
            .Parent.[a1].Resize(iii, 12) = z
        End With
        
    End Sub
    We now have a reputation system in place. If my reply helped please "Like" the reply by clicking the "Like" icon at bottom right of my reply.

    Comment


    • #3
      Just realised that if there were over 2000 rows of data and nearly all had all 87 6-column-blocks filled then the number of rows needed to rearrange the data as required could exceed the total number of rows available on a worksheet. This code includes an error trap to account for the possibility of insufficient rows to rearrange the data.
      Code:
      Sub RearrangeData()
          Dim x, y(), z, i As Long, ii As Long, iii As Long, iv As Long, v As Long
          
          With ActiveSheet.Cells(1).CurrentRegion
              x = .Value2
              For i = 1 To UBound(x, 1)
                  iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
                  For ii = 1 To 12
                      y(ii, iii) = x(i, ii)
                  Next
                  iv = 13
                  Do Until x(i, iv) = vbNullString
                      v = 6
                      iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
                      For ii = iv To iv + 5
                          v = v + 1
                          y(v, iii) = x(i, ii)
                      Next
                      iv = iv + 6
                      If iv >= UBound(x, 2) Then Exit Do
                  Loop
              Next
              If iii > .Parent.Rows.Count Then
                  MsgBox "There are insufficient rows on the worksheet to rearrange the data.", 16, "Data too large"
                  Exit Sub
              End If
              ReDim z(1 To iii, 1 To 12)
              For i = 1 To iii
                  For ii = 1 To 12
                      z(i, ii) = y(ii, i)
                  Next
              Next
              .Clear
              .Parent.[a1].Resize(iii, 12) = z
          End With
          
      End Sub
      We now have a reputation system in place. If my reply helped please "Like" the reply by clicking the "Like" icon at bottom right of my reply.

      Comment


      • #4
        Originally posted by KjBox View Post
        Try this. Run the macro with the data sheet active
        Code:
        Sub RearrangeData()
        Dim x, y(), z, i As Long, ii As Long, iii As Long, iv As Long, v As Long
        
        With ActiveSheet.Cells(1).CurrentRegion
        x = .Value2
        For i = 1 To UBound(x, 1)
        iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
        For ii = 1 To 12
        y(ii, iii) = x(i, ii)
        Next
        iv = 13
        Do Until x(i, iv) = vbNullString
        v = 6
        iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
        For ii = iv To iv + 5
        v = v + 1
        y(v, iii) = x(i, ii)
        Next
        iv = iv + 6
        If iv >= UBound(x, 2) Then Exit Do
        Loop
        Next
        
        ReDim z(1 To iii, 1 To 12)
        For i = 1 To iii
        For ii = 1 To 12
        z(i, ii) = y(ii, i)
        Next
        Next
        .Clear
        .Parent.[a1].Resize(iii, 12) = z
        End With
        
        End Sub
        Nailed it! I now have six thousand rows of data all perfectly parsed and ready to go. Thanks a million KjBox, I know that's a deceptively tricky thing to do and would have been well beyond me. You've made my day - and made my boss a very, happy man.

        Jeff

        Comment


        • #5
          Originally posted by KjBox View Post
          Just realised that if there were over 2000 rows of data and nearly all had all 87 6-column-blocks filled then the number of rows needed to rearrange the data as required could exceed the total number of rows available on a worksheet. This code includes an error trap to account for the possibility of insufficient rows to rearrange the data.
          Code:
          Sub RearrangeData()
          Dim x, y(), z, i As Long, ii As Long, iii As Long, iv As Long, v As Long
          
          With ActiveSheet.Cells(1).CurrentRegion
          x = .Value2
          For i = 1 To UBound(x, 1)
          iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
          For ii = 1 To 12
          y(ii, iii) = x(i, ii)
          Next
          iv = 13
          Do Until x(i, iv) = vbNullString
          v = 6
          iii = iii + 1: ReDim Preserve y(1 To 12, 1 To iii)
          For ii = iv To iv + 5
          v = v + 1
          y(v, iii) = x(i, ii)
          Next
          iv = iv + 6
          If iv >= UBound(x, 2) Then Exit Do
          Loop
          Next
          If iii > .Parent.Rows.Count Then
          MsgBox "There are insufficient rows on the worksheet to rearrange the data.", vbCritical, "Data too large"
          Exit Sub
          End If
          ReDim z(1 To iii, 1 To 12)
          For i = 1 To iii
          For ii = 1 To 12
          z(i, ii) = y(ii, i)
          Next
          Next
          .Clear
          .Parent.[a1].Resize(iii, 12) = z
          End With
          
          End Sub
          That's fine - the vast majority of the rows have four data sets or fewer, and there's only one that has eighty-seven. Still, it's always good to cover the bases if you can, saves you wondering in a year's time why your perfectly functioning macro suddenly stopped working. :D

          Comment


          • #6
            You're welcome.

            You are right, it is always a good idea to include error traps even if the possibility of an error occurring is remote.
            We now have a reputation system in place. If my reply helped please "Like" the reply by clicking the "Like" icon at bottom right of my reply.

            Comment


            • #7
              Hi HjBox, good morning everybody,

              I've now got my next file which I've tweaked and edited to be in the same format as the last file I "rearranged"... but when I try and run the macro on it, it falls over. I get:

              "Run-time error '9':

              Subscript out of range
              ... and when I de-bug, it's highlighting:

               
              y(v, iii) = x(i, ii)


              I'm pretty sure there's something different about my data but I can't figure out what it is, nor why it would affect the macro. Any ideas why this is no longer working?

              Cheers

              Jeff

              Comment


              • #8


                Okay, disaster averted. I started from scratch with my data and this time, it's worked. The only thing I'm aware of doing differently is that first time round, I converted the text values in column A to numbers, and the second time I didn't. Was that why it fell over?

                Jeff

                Comment

                Working...
                X