Excel-VBA：合並具有拆分數據的列，其中標題相差一個特定字符

Question

我正在設置一個無需手動操作即可導入和排序數據的工作簿。

一些需要導入的數據包含分為兩列的數據，其中標頭相差一個字符。 我在這里上傳了一個示例： 示例表

具有分割數據的標題為“ 11，0-3-1m Jord”和“ 11，0-3-1m。Jord”，其區別在於點 。 要導入的圖紙之間的頁眉的可變部分是“ 11，0-3-1m”，帶或不帶點，因為這是用戶定義的樣品的名稱。 “ Jord”是一個常數，因為它將樣品歸類為污垢樣品，並且在要導入的紙張之間不會改變。 數據的第一行（第7行）在拆分列中包含“ Torrstoff”的重復數據，合並時其中一個與空行一起需要刪除。

那么，這有意義嗎？

總結一下：

1. 在第6行中搜索名稱相同但只有一個點的標題
2. 合並這些列，還刪除行7“ Torrstoff”的重復數據。

我的編輯基於@TimWilliams代碼。

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