时间戳

首页 > 解决方案 > VBA找到相同值的第二个实例（列名）

excel - VBA找到相同值的第二个实例（列名）

问题描述

我有 2 个具有相同列名的工作簿。工作簿 1 为空，我在工作簿 1 中粘贴工作簿 2 中的值。

我有一个我需要的列列表（有些列重复，因为相同命名的列中有不同的数据），所以代码的步骤如下

  1. 从列表中获取第一列名称
  2. 转到 wkb2 查找列名并复制该列中的所有数据
  3. 转到 wkb1 找到列名，粘贴该列中的所有数据

问题是，我有一些重复的列名，例如：

wkb1 - column names                         wkb2 - column names
x  x  x  x  A  B  C  x  x  x  A  B  C       x  x  x  x  A  B  C  x  x  x  A  B  C
.  .  .  .  .  .  .  .  .  .  .  .  .       .  .  .  .  .  .  .  .  .  .  .  .  .   
.  .  .  .  .  .  .  .  .  .  .  .  .       .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .       .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .       .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .       .  .  .  .  .  .  .  .  .  .  .  .  .
.  .  .  .  .  .  .  .  .  .  .  .  .       .  .  .  .  .  .  .  .  .  .  .  .  .

一旦我到达重复的列，宏不会向前移动（向右，下一列），但它会采用它找到的具有相同名称的第一列，例如第一列 A 而不是第二列 A。

我想不出一个下降的解决方案。

谢谢你。

PS 下面的代码我粘贴了一个解决当前问题的工作解决方案，因为我有很多失败的代码迭代以及如何处理所述问题的失败想法。

Public DailyFolder As String
Public DailyHSBC As String

Public wkb_macro As Excel.Workbook
Public wks_macro As Excel.Worksheet

Public wkb_HSBC_concat As Excel.Workbook
Public wks_HSBC_concat As Excel.Worksheet

Public wkb_HSBC_raw As Excel.Workbook
Public wks_HSBC_raw As Excel.Worksheet

Sub ConcatFiles()

    Dim HSBC_temp As Excel.Workbook

    HSBC_columns = wks_macro.Range(Range("H2"), Range("H2").End(xlDown))
    HSBC_FileList = wks_macro.Range(Range("E2"), Range("E2").End(xlDown))

    Fund_Accounting_Positions = wks_macro.Range("D5")

    Workbooks.Add.SaveAs (DailyHSBC & "\concatenate_HSBC.csv")

    Set wkb_HSBC_concat = Excel.Workbooks("concatenate_HSBC.csv")
    Set wks_HSBC_concat = Excel.Worksheets("Sheet1")

    x = 1

    For Each col In HSBC_columns

        wks_HSBC_concat.Cells(1, x).Value = col
        x = x + 1

    Next

    y = 1
    msg = "Files not processed:"

    For Each Item In HSBC_FileList

        ofs_rows = wks_HSBC_concat.Cells(Rows.Count, 1).End(xlUp).Row

        Set HSBC_temp = Workbooks.Open(DailyHSBC & Item & "*.*")

        On Error Resume Next
        For Each col In HSBC_columns

            HSBC_temp.Sheets(Fund_Accounting_Positions).Range(HSBC_temp.Sheets(Fund_Accounting_Positions).Cells.Find(What:=col, MatchCase:=True).Offset(1, 0).Address, HSBC_temp.Sheets(Fund_Accounting_Positions).Cells.Find(What:=col, MatchCase:=True).End(xlDown).Address).Copy

            If err.Number <> 0 Then

                msg = msg & vbCrLf & Item
                GoTo Line1

            Else
                wks_HSBC_concat.Cells.Find(What:=col, MatchCase:=True).Offset(ofs_rows, 0).PasteSpecial  

                End If

            End If

        Next

Line1:

        HSBC_temp.Close
    Next

MsgBox msg

End Sub

标签： excelvba

解决方案

这似乎是一个有趣的情况。看看下面的列映射逻辑是否对您有帮助。

Public Sub ColumnLogic()
Dim wkbDest As Workbook: Set wkbDest = Workbooks("Book2 (version 1).xlsb")
Dim wkbSrce As Workbook: Set wkbSrce = Workbooks("Book1 (version 1).xlsb")
Dim wksDest As Worksheet: Set wksDest = wkbDest.Worksheets("Sheet1")
Dim wksSrce As Worksheet: Set wksSrce = wkbSrce.Worksheets("Sheet1")
Dim objDict As Object
Dim i As Long, j As Long, k As Long
Dim lngArr()
ReDim lngArr(wksDest.Cells(1, wksDest.Columns.Count).End(xlToLeft).Column - 1)

'Map columns
Set objDict = CreateObject("Scripting.Dictionary")
For i = 1 To wksDest.Cells(1, wksDest.Columns.Count).End(xlToLeft).Column
    If objDict.exists(wksDest.Cells(1, i).Value) Then
        k = objDict(wksDest.Cells(1, i).Value) + 1
    Else
        k = 1
    End If
    For j = k To wksSrce.Cells(1, wksSrce.Columns.Count).End(xlToLeft).Column
        If wksDest.Cells(1, i).Value = wksSrce.Cells(1, j).Value Then
            lngArr(i - 1) = j
            If objDict.exists(wksDest.Cells(1, i).Value) Then
                objDict(wksDest.Cells(1, i).Value) = j
            Else
                objDict.Add wksDest.Cells(1, i).Value, j
            End If
            Exit For
        End If
    Next
Next i

'\\ Loop through mapped columns
For i = 0 To UBound(lngArr)
    '\\ For wksDest use column index by i + 1
    '\\ For wksSrce use stored value in array lngArr(i)
Next i

End Sub

您显然必须更改变量以适应您的情况，包括您匹配的标题行。

推荐阅读