VBA适配动态非连续表头：实现跨表匹配并复制对应邮箱列数据

目标是创建单个单元格对应一个邮箱的邮件列表表格，现有VBA代码在Sheet1「Mail List」和Sheet2「Build」间切换以提升易用性。Sheet2的K-N列表头可能存在或为空，实际工作表中每个“if applicable”单元格配有IF公式。当前代码仅能识别连续的Header 1-3，当表头跳至Header 6时无法继续识别，若将K7单元格改为Header 4则代码可正常运行。需修改代码以支持搜索Header 4至最后一个表头，无需调整用户友好的表头顺序。

Sheet1「Mail List」 #

Sheet2「Build」 #

现有VBA代码 #

Sub GetEmailAddressETA()

    Dim i As Integer, j As Integer
    Dim lastColumnETA As Long, lastRowETA As Long
    Dim ETAeach As Range
    
    Dim k As Integer
    
    Dim cCell As Range
    Dim lCell As Range
    
    Set sh1 = Sheets("MailList")
    Set sh2 = Sheets("Build")
    
    Dim lastRowL As Long, lastBuildL As Long
    Dim lrg As Range, ETArng As Range
    
    sh1.Select
    lastColumnETA = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
    
    For j = 1 To lastColumnETA 'Intended to be dynamic for future-proofing
        Set cCell = sh1.Cells(1, j) 'Intended for each header in 'MailList' to be a criteria cell
        lastRowETA = sh1.Cells(sh1.Rows.Count, j).End(xlUp).Row 'For each header to have dynamic last row
        Set ETArng = sh1.Range(sh1.Cells(2, j), sh1.Cells(lastRowETA, j))  'Set range to copy if later found applicable
        
        sh2.Select 'change sheet
        For k = 11 To 11 'ideally, will be k = 11 to 14 representing column K-N
        
        lastRowL = sh2.Cells(sh2.Rows.Count, k).End(xlUp).Row   'for dynamic last row in look-up
        Set lrg = sh2.Range(Cells(4, k), Cells(lastRowL, k))  'set look-up range with dynamic range
        
            For Each lCell In lrg.Cells

                If cCell.Value = lCell.Value Then 'if cell matches sh1's Header

                    lastBuildL = sh2.Cells(sh2.Rows.Count, k - 9).End(xlUp).Row 'look for last filled row in column B
                    ETArng.Copy
                    Range(Cells(lastBuildL + 1, k - 9), Cells(lastBuildL + 1, k - 9)).PasteSpecial Paste:=xlPasteValues 'paste sh1 range for applicable header, into column B

                    Exit For
                    
                End If
            Next lCell

        Next k
            
    Next j
    
End Sub

Sub GetEmailAddressETA()
    Dim j As Integer, k As Integer
    Dim lastColumnETA As Long, lastRowETA As Long
    Dim cCell As Range, lCell As Range
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim lastRowL As Long, lastBuildL As Long
    Dim lrg As Range, ETArng As Range
    Dim headerMatch As String
    
    ' 初始化工作表对象
    Set sh1 = Sheets("MailList")
    Set sh2 = Sheets("Build")
    
    ' 获取MailList的最后一列
    lastColumnETA = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
    
    ' 遍历MailList的所有表头列
    For j = 1 To lastColumnETA
        Set cCell = sh1.Cells(1, j)
        lastRowETA = sh1.Cells(sh1.Rows.Count, j).End(xlUp).Row
        Set ETArng = sh1.Range(sh1.Cells(2, j), sh1.Cells(lastRowETA, j))
        
        ' 遍历Build表的K-N列（11到14列）
        For k = 11 To 14
            ' 跳过空列
            If sh2.Cells(1, k).Value <> "" Then
                lastRowL = sh2.Cells(sh2.Rows.Count, k).End(xlUp).Row
                Set lrg = sh2.Range(sh2.Cells(4, k), sh2.Cells(lastRowL, k))
                
                ' 遍历当前列的查找范围
                For Each lCell In lrg.Cells
                    ' 提取表头核心名称，忽略"(if applicable)"后缀
                    headerMatch = Trim(Split(lCell.Value, "(")(0))
                    
                    ' 不区分大小写匹配表头
                    If StrComp(cCell.Value, headerMatch, vbTextCompare) = 0 Then
                        ' 获取目标列的最后一行
                        lastBuildL = sh2.Cells(sh2.Rows.Count, k - 9).End(xlUp).Row
                        ' 逐行粘贴非空邮箱
                        Dim emailRow As Integer
                        For emailRow = 1 To ETArng.Rows.Count
                            If ETArng.Cells(emailRow, 1).Value <> "" Then
                                sh2.Cells(lastBuildL + emailRow, k - 9).Value = ETArng.Cells(emailRow, 1).Value
                            End If
                        Next emailRow
                        Exit For
                    End If
                Next lCell
            End If
        Next k
    Next j
    
    ' 清除剪贴板并返回Build表
    Application.CutCopyMode = False
    sh2.Select
End Sub

• 表头匹配逻辑优化：通过拆分字符串提取表头核心名称，忽略"(if applicable)"后缀，解决带后缀表头无法匹配的问题。
• 扩展遍历范围：将K列单循环改为K-N列（11到14列）循环，覆盖所有目标表头列。
• 空列跳过：增加空列判断，避免对无表头的列进行无效遍历。
• 逐行粘贴非空值：替换原整列粘贴逻辑，逐行检查并粘贴非空邮箱，实现单个单元格对应一个邮箱的需求。
• 不区分大小写匹配：使用StrComp函数实现大小写不敏感匹配，提升兼容性。

内容的提问来源于stack exchange，提问作者babyy bluebear