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