VBA Code for Excel to copy and transpose-paste a range of cells depending on content

Question

I have an Excel table which may contain such:

Screenshot of content from a table, columns C and D

It may be much longer on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.

I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:

a screenshot from destination table

It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.

To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like

Final look of the destination table

In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.

I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.

Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.

-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way: this is closer to what it really looks like

I changed the constants here:

enter code here Const sName As String = "Tabelle1" ' Source Worksheet Name enter code here Const sFirst As String = "C2" ' Source First Cell Address enter code here Const tName As String = "Tabelle2" ' Target Worksheet Name enter code here Const tFirst As String = "B1" ' Target First Cell Address

The groups will actually be constant in length, actually more than 11, but that can be fixed later.

These:

1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -

I pasted this already into target sheet.

What I get from my test using my thus modified solution from VBasic2008 is this:

Afghanistan | AF    Åland Islands | AX  Albania | AL    Algeria | DZ    American Samoa | AS Belgium | BE    Belize | BZ 24tst   Bermuda | BM    Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ   Bosnia and Herzegovina | BA Botswana | BW   Algeria | DZ    Brazil | BR Christmas Island | CX   Cocos (Keeling) Islands | CC    Colombia | CO   Comoros | KM    n/a Congo | CD

This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?

Answer 1

I think the easiest way of doing this is looping through cells with headers and checking each value. When you find your "next-group" cell then trigger some ifs;

Example program which covers your problem below:

Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1

'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell

'Set first column
Dim firstcolumn As Integer
firstcolumn = 1

'find last column
Dim lastcolumn As Integer
lastcolumn = 2


'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")

Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)

'Copy headers
cnt = 0
For i = firstrow To lastrow
    If Cells(i, lastcolumn).Value = "next-group" Then Exit For
    Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
    cnt = cnt + 1
Next i


'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
    'If we have text "next group"
    If Cells(i, lastcolumn).Value = "next-group" Then
        cnt = 0 'start with first column
        cnt2 = cnt2 + 1 'Start with next row
        'This cell is not copied
    Else
        'cell is copied
        Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
        'column counter is increased
        cnt = cnt + 1
    End If
Next i

'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"

'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"

End Sub

I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).

UPDATE: I didnt put "=" inside R1C1 formula, now its fixed. UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update

Answer 2

A Copy Transpose

• This will work correctly only if the data is consistent ie 11 rows of data and 1 empty ( Next-Group ) row (can be changed in the constants section) ie if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.

• The following image shows what the current setup in the code will produce (without the formatting).

The Code

Option Explicit

Sub transposeData()
    
    Const sName As String = "Sheet1" ' Source Worksheet Name
    Const sFirst As String = "A2"    ' Source First Cell Address
    Const tName As String = "Sheet1" ' Target Worksheet Name
    Const tFirst As String = "D1"    ' Target First Cell Address
    Const NoE As Long = 11           ' Number of Elements  
    Const NoER As Long = 1           ' Number of Empty Rows
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Define Source Worksheet ('ws').
    Dim ws As Worksheet
    Set ws = wb.Worksheets(sName)
    ' Define Source First Cell ('First').
    Dim First As Range
    Set First = ws.Range(sFirst)
    ' Define Source Last Cell ('Last').
    Dim Last As Range
    Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
    If Last.Row - First.Row + 1 < NoE Then
        GoTo ProcExit
    End If
    ' Define Source Range ('rng').
    Dim rng As Range
    Set rng = ws.Range(First, Last)
    
    ' Write values from Source Range to Source Array ('Source').
    Dim Source As Variant
    Source = rng.Value
    
    ' Define number of Data Sets ('NoDS').
    Dim NoDS As Long
    NoDS = Int(UBound(Source, 1) / (NoE + NoER))
    
    ' Define Target Number of Rows ('NoR').
    Dim NoR As Long
    NoR = NoDS + 1
    
    ' Define Target Array ('Target').
    Dim Target As Variant
    ReDim Target(1 To NoR, 1 To NoE)
    
    ' Declare additional variables for the upcoming loops.
    Dim CurrentValue As Variant ' Source Current Value
    Dim CurrentLR As Long       ' Source Current Last Row
    Dim j As Long               ' Target Columns Counter
    Dim i As Long               ' Target Rows Counter
    
    ' Write headers.
    For j = 1 To NoE
        Target(1, j) = Source(j, 2)
    Next j
    ' Write data.
    For i = 2 To NoR
        CurrentLR = (i - 2) * (NoE + NoER)
        For j = 1 To NoE
            CurrentValue = Source(CurrentLR + j, 1)
            If Not IsEmpty(CurrentValue) Then
                Target(i, j) = CurrentValue
            Else
                Target(i, j) = Target(i - 1, j)
            End If
        Next j
    Next i
    
    ' Define Target Worksheet ('ws').
    Set ws = wb.Worksheets(tName)
    ' Define Target First Cell ('First').
    Set First = ws.Range(tFirst)
    ' Define Target Range ('rng').
    Set rng = First.Resize(NoR, NoE)
    
    ' Write values from Target Array to Target Range.
    rng.Value = Target
    
    ' Inform user
    MsgBox "Data transferred.", vbInformation, "Success"
    
ProcExit:
End Sub

EDIT

Tiny Change

Instead of Target(i, j) = Target(i - 1, j) use

            If i > 2 Then
                Target(i, j) = Target(i - 1, j)
            End If