从另一个工作表的单元格列替换第一行中的标题名称

Question

我正在尝试在 VBA 中实现以下自动化。我有不同的表格，但标题错误。我有另一个名为“HeadersMap”的工作表，其中包含所有工作表正确标题的列表。我想要做的是，如果我打开一个“Sheet1”，那么代码应该转到“HeadersMap”工作表>检查“SheetNames”列中打开的工作表名称>检查“OriginalHeaders”列中的原始标题并复制正确“正确标题”列中的标题名称，并替换“Sheet1”中的标题。同样，如果我打开“Sheet2”，它也应该这样做。

“表 1”

	A	B	C
1	aplpe	baanann	Roange
2
3

表格“标题图”

	A	B	C
1	SheetNames	OriginalHeaders	CorrectHeaders
2	Sheet1	aplpe	Apple
3	Sheet1	baanann	Banana
4	Sheet1	Roange	Orange
5	Sheet2	sgura	Sugar
6	Sheet2	Jggaery	Jaggery
7	Sheet3	Dtergetn	Detergent
8	Sheet3	poas	Soap
9	Sheet3	Lfua	Lufa

所需结果“SHEET1”

	A	B	C
1	Apple	Banana	Orange
2
3

Answer 1

试试，

Sub test()
    Dim Ws As Worksheet
    Dim vDB As Variant
    Dim rngHeader As Range
    Dim i As Integer
    
    Set Ws = Sheets("HEADERSMAP")
    
    vDB = Ws.Range("a1").CurrentRegion
    
    For i = 2 To UBound(vDB, 1)
        If isHas(vDB(i, 1)) Then
            Set Ws = Sheets(vDB(i, 1))
            Set rngHeader = Ws.Rows(1)
            rngHeader.Replace vDB(i, 2), vDB(i, 3)
        End If
    Next i
End Sub
Function isHas(v As Variant) As Boolean
    Dim Ws As Worksheet
    For Each Ws In Worksheets
        If Ws.Name = v Then
            isHas = True
            Exit Function
        End If
    Next Ws
End Function

Answer 2

正确的标题

编辑

• 阅读您的评论后，最好将完整代码复制到ThisWorkbook 模块（如果您坚持使用此功能）。无需添加其他模块。

---

• 假设工作表HeadersMap中的数据从单元格A1开始。

标准模块，例如Module1

Option Explicit

Sub correctHeaders(ws As Worksheet)
    
    Const sName As String = "HeadersMap"
    Const sFirst As String = "A1"
    
    Dim rg As Range
    Dim Data As Variant
    
    Set rg = ThisWorkbook.Worksheets(sName).Range(sFirst).CurrentRegion
    If IsNumeric(Application.Match(ws.Name, rg.Columns(1), 0)) Then
    
        Data = rg.Value
        
        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        Dim Result() As Variant
        Dim r As Long, j As Long
        For r = 1 To UBound(Data, 1)
            If StrComp(Data(r, 1), ws.Name, vbTextCompare) = 0 Then
                j = j + 1
                ReDim Preserve Result(1 To 2, 1 To j)
                Result(1, j) = Data(r, 2)
                Result(2, j) = Data(r, 3)
            End If
        Next r
        
        If j > 0 Then
            Set rg = ws.UsedRange.Rows(1)
            Data = rg.Value
            Dim cIndex As Variant
            For j = 1 To j
                cIndex = Application.Match(Result(1, j), Data, 0)
                If IsNumeric(cIndex) Then
                    Data(1, cIndex) = Result(2, j)
                End If
            Next j
            rg.Value = Data
        End If
    
    End If

End Sub

附加功能（您必须运行它）

Sub correctHeadersApply
    Dim ws As Worksheet
    For Each ws in Thisworkbook.Worksheets
        correctHeaders ws
    Next ws
End Sub        

ThisWorkbook 模块

Option Explicit

Private Sub Workbook_Open()
    correctHeaders ActiveSheet
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Type = xlWorksheet Then
        correctHeaders Sh
    End If
End Sub

Answer 3

最低限度可能会将其放入 ThisWorkbook：

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim targetRange As Range, i As Long
Set targetRange = Worksheets("HEADERSMAP").Range("A1:A9")
i = 1
    For Each entry In targetRange
        If entry.Value = Sh.NAME Then
            Sh.Cells(1, i) = entry.Offset(, 2).Value
            i = i + 1
        End If
    Next
End Sub

如果数据看起来像您的示例。 稍后您可能希望将Range("A1:A9") 更改为查找最后一行，并将Offset(, 2) 更改为Offset(, 1)，因为“OriginalHeaders”列实际上是多余的。

模块版本类似于：

Sub headers()
Dim targetRange As Range, i As Long, Sh As Worksheet
Set Sh = Worksheets(InputBox("Enter name of sheet"))
Set targetRange = Worksheets("HEADERSMAP").Range("A1:A9")
i = 1
    For Each entry In targetRange
        If entry.Value = Sh.NAME Then
            Sh.Cells(1, i) = entry.Offset(, 2).Value
            i = i + 1
        End If
    Next
End Sub

也就是说，如果工作表的名称和列表中的项目相关。 您可以使用第二个输入框设置第二个变量，并替换 Sh.NAME 以手动从列表中选择。 像这样：

Sub headers()
Dim targetRange As Range, i As Long, Sh As Worksheet, name As String
Set Sh = Worksheets(InputBox("Enter name of sheet"))
name = InputBox("Enter name from map")
Set targetRange = Worksheets("HEADERSMAP").Range("A1:A9")
i = 1
    For Each entry In targetRange
        If entry.Value = name Then
            Sh.Cells(1, i) = entry.Offset(, 2).Value
            i = i + 1
        End If
    Next
End Sub

然后你可以手动输入witch sheet get what headers，如果你愿意的话。