Using VBA to combine headers (based on name) and concatenate columns based on conditions

[Tom224]

In ponctualy receive a file that I would like to reorganize.

I am thus looking for specific headers names and either renaming them and copying data or doing more complex operations.

In the simplest case, I am only renaming columns and pasting the new columns headers and content in a second sheet.
I am looking for a column named "Spec A" and renaming it "Nabou"

For a more complex case, I am creating a new column by concatenating columns.
However, based on wether or not the information is present in other columns, I am adding a specific text, which can change in various cases.
For example, I am concatenating a sevaral columns "nup", "nap", and adding "WAGA" for rows with values located below some specific headers, and adding "CIOCOLATO" for the rows with no values located in these same headers.
The two possible results being:

• nup_nap_WAGA_Snip (for the caeses when specific rows have values below)
• nup_nap_CIOCOLATO_Snip (for the cases when rows below specific headers have no values)

For the worst case, in this same file, I am creating new columns, by concatenating these columns, but I am also appending a specific number in some cases.
In oder to know the number that I am incrementing, I need to look on another exel file (another worksheet) to add a specific input in the increment, which should be increment based on specific condition.

Finally, I am also concatenating columns and their content with a line break.


I have the following code

Option Explicit

Sub Snouba()

    Const q = """"

' get source data table from sheet 1
    With ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion
        ' check if data exists

        If .Rows.Count < 2 Or .Columns.Count < 2 Then
            MsgBox "No data table"
            Exit Sub
        End If

        ' retrieve headers name and column numbers dictionary
        Dim headers As Object
        Set headers = CreateObject("Scripting.Dictionary")
        Dim headCell
        For Each headCell In .Rows(1).Cells
            headers(headCell.Value) = headers.Count + 1
        Next

        ' check mandatory headers
        For Each headCell In Array("Nabou", "Wurp", "Scope 1", "Scope 2", "Scope 3”, "Scope 4", "NipandNup")
            If Not headers.Exists(headCell) Then
                MsgBox "Header '" & headCell & "' doesn't exists"
                Exit Sub
            End If

        Next

        Dim data

        ' retrieve table data
        data = .Resize(.Rows.Count - 1).Offset(1).Value
    End With

    ' process each row in table data
    Dim result As Object
    Set result = CreateObject("Scripting.Dictionary")
    Dim i
    For i = 1 To UBound(data, 1)


     Select Case True
            Case _
                data(i, headers("NipandNup")) = "Nip"
                    MsgBox "Empty row"
                    Exit For

            Case _
                  result(result.Count) = "Nip"

            Case Else
                     result(result.Count) = "Nup"

               End Select








        Select Case True
            Case _
                data(i, headers("Nabou")) = "" Or _
                data(i, headers(""Wurp")) = "" Or _
                data(i, headers("NipandNup")) = ""
                    MsgBox "Empty row"
                    Exit For
Case _
                data(i, headers("Scope 1")) = "" And _
                data(i, headers("Scope 2")) = "" And _
                data(i, headers("Scope 3")) = "" And _
                data(i, headers("Scope 4")) = ""
                    result(result.Count) = _
                        data(i, headers("Nabou")) & _
                        "_Alpha" & _
                        "_" & data(i, headers("Wurp")) & _
                        "_" & data(i, headers("NipandNup"))



Case Else
result(result.Count) = _
                        data(i, headers("Nabou")) & _
                        "_Alphabet" & _
                        "_" & data(i, headers("Wurp")) & _
                        "_" & data(i, headers("NipandNup"))

End Select

Next

' output result data to sheet 2
If result.Count = 0 Then
        MsgBox "No result data for output"
        Exit Sub
End If
With ThisWorkbook.Sheets(2)
.Cells.Delete
.Cells(1, 1).Resize(result.Count).Value = _
WorksheetFunction.Transpose(result.Items())
End With
    MsgBox "Completed"

End Sub

And I am trying to merge it and improve the code to change the colomns name:

Option Explicit

Sub Changeheadername()

    Dim lastCol As Long, idCount As Long, nameCount As Long, headerRow As Long
    Dim rng As Range, cel As Range

    headerRow = 1       'row number with headers
    lastCol = Cells(headerRow, Columns.Count).End(xlToLeft).Column 'last column in header row
    idCount = 1
    nameCount = 1
    Set rng = Sheets("Sheet1").Range(Cells(headerRow, 1), Cells(headerRow, lastCol)) 'header range

    For Each cel In rng                     'loop through each cell in header
        If cel = "Wurp" Then             'check if header is "Wurp"
            cel = "Snouba"                    'rename 

        ElseIf cel = "Nabou" Then       'check if header is "Nabou"
            cel = "WAGD"                     'rename 

              ElseIf cel = "Scope 1" Then       'check if header is "Scope 1"
            cel = "I am an a wise rabbit"             

        End If
    Next cel
End Sub

I am also trying to improve and merge this macro in which I am concatenating columns with a line break.

Do you know to merge these VBA macro ?
Do you know how these macros could be improved ?