我有一个脚本，用于将多个列与相同的标题组合成一列。但是，该脚本正在删除第一列中具有相同值的行。这个脚本是为了清理我的工作表，所以我想保留所有数据行，只是整理带有重复标题的列。
Dim source As Worksheet, target As Worksheet
Dim uniques As New Scripting.Dictionary
Dim current As New Scripting.Dictionary
Dim found As New Scripting.Dictionary
Set source = ActiveSheet
Set target = ActiveWorkbook.Worksheets("all data")
Set current = New Scripting.Dictionary
Set found = New Scripting.Dictionary
Set uniques = New Scripting.Dictionary
Dim row As Long, col As Long, targetRow As Long, targetCol As Long
targetRow = 2
targetCol = 1
Dim activeVal As Variant
For row = 1 To source.UsedRange.Rows.Count
'Is the row a header row?
If source.Cells(row, 1).Value2 = "WSTD_counts" Then
'Reset the current column mapping.
Set current = New Scripting.Dictionary
For col = 1 To source.UsedRange.Columns.Count
activeVal = source.Cells(row, col).Value2
If activeVal <> vbNullString Then
current.Add col, activeVal
'Do you already have a column mapped for it?
If Not found.Exists(activeVal) Then
found.Add activeVal, targetCol
targetCol = targetCol + 1
End If
End If
Next col
Else
activeVal = source.Cells(row, 1).Value2
'New unique name?
If Not uniques.Exists(activeVal) Then
'Assign a row in the target sheet.
uniques.Add activeVal, targetRow
target.Cells(targetRow, 1).Value2 = activeVal
targetRow = targetRow + 1
End If
For col = 1 To source.UsedRange.Columns.Count
'Copy values.
activeVal = source.Cells(row, col).Value2
If source.Cells(row, col).Value2 <> vbNullString Then
target.Cells(uniques(source.Cells(row, 1).Value2), _
found(current(col))).Value2 = activeVal
End If
Next col
End If
Next row
'Write headers to the target sheet.
target.Cells(1, 1).Value2 = "all data"
For Each activeVal In found.Keys
target.Cells(1, found(activeVal)).Value2 = activeVal
Next activeVal
'Delete part b & c data.
Worksheets("all data").Range("a32:bk100").Clear
End Sub