I'm new to the forum and also new to learning about VBA. I already spent more than 5,000 hours with Excel, but not more than 40 hours with VBA.

I am trying to solve a problem with VBA and fail to solve the task.

I would like to arrange the associated title (A, B, C) from the cell range B4: D11 in the new table F4: Q11.

Table Input and Output

My approach is as follows:

1. Convert month as a number (e.g. March is the number 3)
2. then I start in the same row (row 4) in column E and move the number of fields to the right (e.g. start at E4 3 fields to the right, then I am at H4).
3. The heading "A" should be pasted in there H4. Unfortunately, I don't know how to get to the eading "A".

Unfortunately, I also don't know how to create a loop from it that goes through all 3 fields (e.g. B4, B5, B6) in each line and then does the same in the line below.

Could someone please help me with the implementation please :)

Thank you in advance!

CodePudding user response：

This is one way to do it. Note the month names must match (some in your screenshot do not - eg. March vs. Marz)

Sub Tester()
    Dim ws As Worksheet, rngMonths As Range
    Dim rw As Range, c As Range, i As Long, v, m
    
    Set ws = ActiveSheet
    Set rngMonths = ws.Range("F3:Q3")
    
    Set rw = ws.Range("A4:D4")                       'first row of name months
    Do While Application.CountA(rw) > 0              'while row is not empty...
        For i = 2 To rw.Cells.Count                  'loop from second cell of row
            Set c = rw.Cells(i)
            v = c.Value
            If Len(v) > 0 Then                         'if cell is not empty
                m = Application.Match(v, rngMonths, 0) 'see if it matches a month
                If Not IsError(m) Then                 'got a match?
                    'populate the header above `c`
                    ws.Cells(rw.Row, rngMonths.Cells(m).Column).Value = _
                                ws.Cells(3, c.Column).Value
                End If
            End If
        Next i
        Set rw = rw.Offset(1, 0) 'move down one row
    Loop
End Sub

CodePudding user response：

Scenario for output F4:Q11

Take a look at below code:

Option Explicit

Sub ArrangeData()
    'define variables:
    Dim wsh As Worksheet, dictMonts As Dictionary
    Dim i As Integer, j As Integer, k As Integer
    Dim h As Integer, hc As Integer, ic As Integer
    Dim sMonth As String
    
    On Error GoTo Err_ArrangeData
    
    'worksheet where data are stored
    Set wsh = ThisWorkbook.Worksheets(1)
    'create dictionary object and load months with corresponding number of month
    Set dictMonts = GetMonths()
    
    'start inserting data in column F
    ic = 6
    'header is in row...
    h = 3
    'column count
    hc = 3
    'loop through the collection of rows
    i = 4
    Do While wsh.Range("A" & i) <> ""
        'start from column 1
        j = 1
        'loop through the collection of columns (on the right of Heading)
        Do While j <= hc
            'if empty cell - skip it and go to the next column:)
            If wsh.Range("A" & i).Offset(ColumnOffset:=j) = "" Then GoTo SkipNext
            'get the name of month
            sMonth = wsh.Range("A" & i).Offset(ColumnOffset:=j)
            'insert a columns header into corresponding cell
            wsh.Cells(i, ic).Offset(ColumnOffset:=dictMonts(sMonth) - 1) = wsh.Range("A" & hc).Offset(ColumnOffset:=j)
            'dictMonts(sMonth) - returns the number of month: 1 to 12
            'so we need to subtract 1 to start from column F[6]
SkipNext:
            j = j   1
        Loop
        i = i   1
    Loop
    
    
Exit_ArrangeData:
    On Error Resume Next
    Set wsh = Nothing
    Exit Sub
    
Err_ArrangeData:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_ArrangeData
End Sub

'function which creates and returns dictionary object
'stores the names of months and related numbers
Private Function GetMonths() As Dictionary
    Dim oDict As Dictionary
    Set oDict = New Dictionary
    
    oDict.Add "Januar", 1
    oDict.Add "Februar", 2
    oDict.Add "Marz", 3
    oDict.Add "April", 4
    oDict.Add "May", 5
    oDict.Add "Juni", 6
    oDict.Add "July", 7
    oDict.Add "August", 8
    oDict.Add "September", 9
    oDict.Add "October", 10
    oDict.Add "November", 11
    oDict.Add "December", 12
        
    Set GetMonths = oDict
    
End Function

You can download 7z archive from my server.

Note: You may see warning about unsafe connection, but i can confirm that everything is OK. I'm using SSL certificate from Let's Encrypt, but that service is temporary unavailable.