Excel-VBA: Merging columns with split data where headers differs by one specific character

Question

I am setting up a workbook that imports and sorts data without the need of manual operations.

Some of the data that needs to be imported contains data split in two columns where the headers differ by one character. I've uploaded an example here: Example sheet

The headers with the split data are "11, 0-3-1m Jord" and "11, 0-3-1m. Jord" where the difference is the dot . The variable part of the header between sheets to be imported is the "11, 0-3-1m" with or without a dot as that is a name of a sample that the is user defined. "Jord" is a constant as it categorize the sample as a dirt sample and will not change between sheets to be imported. The first row of data (row 7) contains duplicate data for "Torrstoff" in the split columns where one of them needs to be deleted together with the empty rows when merging.

So, does this make sense?

To sum up:

1. Searches row 6 for headers with the same name that only differs by a dot
2. Merges these columns and also deletes the duplicate data for row 7 "Torrstoff".

My edit based on @TimWilliams code.

Const HDR_ROW As Long = 6
Dim c As Range, sht As Worksheet, f As Range
Dim lr As Long, r As Long, tmp, delCol As Boolean

Set ws2 = wb2.Worksheets(1)
Set c = ws2.Cells(HDR_ROW, ws2.Columns.Count).End(xlToLeft)

Do While c.Column > 2
    delCol = False 'reset delete flag
    'look for a matching column header
    Set f = ws2.Rows(HDR_ROW).Find(Replace(c.Value, ".", ""), _
                                    lookat:=xlWhole)
    'found a column and it's not the same one we're working on...
    If Not f Is Nothing And f.Column <> c.Column Then
        Debug.Print c.Address(), f.Address()
        lr = ws2.Cells(ws2.Rows.Count, c.Column).End(xlUp).Row
        'move any non-blank values over (source data has lots of spaces?)
        For r = HDR_ROW + 2 To lr
            tmp = Trim(ws2.Cells(r, c.Column).Value)
            If Len(tmp) > 0 Then
                ws2.Cells(r, f.Column).Value = tmp
            End If
        Next r
        delCol = True 'going to delete this column
    End If
    Set c = c.Offset(0, -1)
    If delCol Then c.Offset(0, 1).EntireColumn.Delete
Loop

Answer 1

Sub Tester()
    Const HDR_ROW As Long = 6
    Dim c As Range, sht As Worksheet, f As Range
    Dim lr As Long, r As Long, tmp, delCol As Boolean

    Set sht = ActiveSheet
    Set c = sht.Cells(HDR_ROW, Columns.Count).End(xlToLeft)

    Do While c.Column > 2
        delCol = False 'reset delete flag

        If Instr(c.Value, ".") > 0 Then

           'look for a matching column header
            Set f = sht.Rows(HDR_ROW).Find(Replace(c.Value, ".", ""), _
                                            lookat:=xlWhole)
            'found a column and it's not the same one we're working on...
            If Not f Is Nothing And f.Column <> c.Column Then
                Debug.Print c.Address(), f.Address()
                lr = sht.Cells(Rows.Count, c.Column).End(xlUp).Row
                'move any non-blank values over (source data has lots of spaces?)
                For r = HDR_ROW + 2 To lr
                    tmp = Trim(sht.Cells(r, c.Column).Value)
                    If Len(tmp) > 0 Then
                        sht.Cells(r, f.Column).Value = tmp
                    End If
                Next r
                delCol = True 'going to delete this column
            End If  'header has a no-"." match

        End If      'header has a "."

        Set c = c.Offset(0, -1)
        If delCol Then c.Offset(0, 1).EntireColumn.Delete
    Loop
End Sub