Excel-VBA：合并具有分隔数据的列，其中标题相差一个特定字符

我正在设置一个工作簿来导入和sorting数据，而不需要手动操作。

某些需要导入的数据包含分成两列的数据，其中标题相差一个字符。 我已经在这里上传了一个例子： 示例表

具有分割数据的标题是“11,0-3-1m Jord”和“11,0-3-1m。Jord”，其中差别是点 。 要导入的图纸之间的标题的可变部分是“11,0-3-1m”，带或不带点，因为这是用户定义的样本的名称。 “Jord”是一个常量，因为它将样品归类为污垢样品，不会在要导入的纸张之间发生变化。 第一行数据（第7行）包含拆分列中“Torrstoff”的重复数据，其中一个数据在合并时需要与空行一起删除。

那么，这是否有意义？

总结一下：

1. 在第6行中search相同名称的标题，这些标题仅相差一点
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