Как пропустить столбец в массиве VBA

Question

У меня есть исходная рабочая книга и конечная рабочая книга, и я хочу отобразить все данные из исходного wb в wb назначения, но столбцы go в определенном порядке c на основе сопоставлений. И заголовок источника, и заголовок назначения могут быть любой длины, но важным из них будет заголовок назначения, потому что я не хочу возвращать все данные, а просто хочу данные, которые мне нужны, на основе сопоставления.

Я застрял в циклах, где мне нужно сместить столбцы, потому что когда я пишу в целевую ББ, он будет писать столбец после столбца, который это не то, что я хотел. Таким образом, если в отображении есть пробел, оставьте этот столбец пустым и перейдите к следующему, и при записи этого в рабочую книгу массив должен иметь такое же количество столбцов, но данные в нужном месте. Любая помощь будет принята с благодарностью, так как я пробовал разные способы, но всегда получаю неправильные данные или не работаю вообще. Приведенное ниже работает, но при записи данных он дозирует, не пропуская того, что отсутствует в отображении, поэтому мне нужно вручную изменить столбцы, чтобы они соответствовали нужным данным в правом столбце, а также скопируйте и вставьте, но я думал, что массив будет намного быстрее в этой задаче, так как данные большие в строках более 300 тыс. строк.

Изображение составлено из разных листов и не будет иметь желтой строки, чтобы прояснить, к каким данным относятся какие данные. Данные, отображающие первую строку, будут иметь имя листа, куда я буду записывать данные.

Option Explicit
Sub DataTransformation()
    Dim wsDataMapping As Worksheet
    Dim targetWS As Worksheet
    Dim sourceWB As Workbook
    Dim targetWB As Workbook
    Dim destMapping As Range
    Dim destMappingCell As Range
    Dim srcData As Range
    Dim destData as Range
    Dim srcArr As Variant
    Dim destArr() As Variant
    Dim LCol As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim sourceLRow As Long
    Dim targetLRow As Long
    Dim remainingFiles As String
    Dim time As Variant
   
    time = Now()
    Application.ScreenUpdating = False
   
    Set targetWB = ActiveWorkbook
    With targetWB
        Set wsDataMapping = .Sheets("Data Mapping")
        Set targetWS = .Sheets(wsDataMapping.Range("A1").value)
    End With
   
    LCol = targetWS.Cells(16, targetWS.Columns.Count).End(xlToLeft).Column
   
    Set destMapping = wsDataMapping.Range("A2:A" & wsDataMapping.Range("A" & wsDataMapping.Rows.Count).End(xlUp).Row)
   
    Dim filePath As String
    Dim fileName As Variant
    Dim allFiles As Collection
    Set allFiles = New Collection
    filePath = "C:\Users\" & Environ(“UserName”) & "\Desktop\Test M" & "\"
    'fileName = Dir(filePath & "*.*")
    Set allFiles = LoopThroughFiles(filePath, ".*")
   
For Each fileName In allFiles
 
    Set sourceWB = Workbooks.Open(filePath & fileName)
    Set srcData = sourceWB.Worksheets(1).Range("A1").CurrentRegion
    Set destData = targetWS.Range(targetWS.Cells(13, 3), targetWS.Cells(13, LCol))
   
    sourceLRow = sourceWB.Worksheets(1).Range("A" & sourceWB.Worksheets(1).Rows.Count).End(xlUp).Row
    targetLRow = FindLastRow(targetWS, 3, LCol)
   
    If (targetWS.Rows.Count - targetLRow) > sourceLRow Then
        srcArr = srcData.value
 
        ReDim Preserve destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
 
        For Each destMappingCell In destMapping
            x = 0
            For i = LBound(srcArr, 2) To UBound(srcArr, 2)
             
                If destMappingCell.Offset(0, 1).value = srcArr(1, i) Then
                    x = x + 1
                    For j = LBound(srcArr, 1) To UBound(srcArr, 1)
                        'Debug.Print srcArr(j, i)
                        destArr(j, x) = srcArr(j, i)
                    Next j
                End If
            Next i
        Next destMappingCell
       
        sourceWB.Close False
        targetWS.Range("C" & targetLRow).Resize(UBound(destArr, 1), UBound(destArr, 2)).value = destArr
    Else
        sourceWB.Close False
        remainingFiles = remainingFiles & " " & fileName & vbNewLine
    End If
Next fileName
 
Application.ScreenUpdating = True
MsgBox time & " after run " & Now() & vbNewLine & "Files remaining to process are " & vbNewLine & remainingFiles
End Sub
Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As Collection
 
    Dim strFile As String
    Dim fileNames As Collection
 
    Set fileNames = New Collection
 
    strFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(strFile) > 0
        'Debug.Print strFile
        fileNames.Add (strFile)
        strFile = Dir 'returns a new file
    Loop
    Set LoopThroughFiles = fileNames
End Function
Function FindLastRow(ByVal ws As Worksheet, Optional ByVal FromCol As Long = 0, Optional ByVal ToCol As Long = 0) As Long
Dim i As Long
Dim lastRow As Long
If FromCol = 0 Then FromCol = 3
If ToCol = 0 Then ToCol = 10
For i = FromCol To ToCol
    lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
    If FindLastRow < lastRow Then
        FindLastRow = lastRow
    End If
Next i
If FindLastRow < 17 Then FindLastRow = 17
End Function
 
 

Answer 1

Решение

Приведенный ниже код работает против моих тестовых рабочих книг. Я считаю, что правильно обработал ваши смещения. Строки, начинающиеся с "###", требуют изменения для вашей системы. Я считаю, что остальные макросы будут работать без изменений. Скопируйте этот код в новый модуль, настройте его и попробуйте. Комментарии в коде должны объяснить все. Если комментарии не подходят, задавайте вопросы, и я буду обновлять комментарии.

Option Explicit

  ' * I have a naming system for my constants and variables that I have used for years.
  '   Having a system means I can look at code I wrote years ago and recognise the
  '   constants and variables.  If you do not like my system, design your own but do
  '   code without a system if you wih to easily maintain old code.
  ' * Col, Inx, Row, Wsht and Wbk identify the name as relating to a column, index,
  '   row, worksheet or workbook.
  ' * Col, Row, Wsht and Wbk are followed by Xxx which is a code or abbreviation
  '   identifying the worksheet or workbook.
  ' * Values for Xxx in these macros are:
  '      Map  for the Data mapping table.
  '      Src  for a source workbook or worksheet
  '      Dest for the destination worksheet
  '      This for the workbook holding the macros and the destination worksheet.
  ' * Next, Crnt, Last destinguish different columns or rows if necessary.
  ' * InxX is an index for a 1D array or collection. Since the use is ArrayName(InxX),
  '   X is usually a single letter.
  ' * ColXxxDataFirst and RowXxxDataFirst define the first data column and row
  '   within worksheet Xxx.  This allows the number of header columns or rows to be
  '   changed with minimum effect on the code.
  ' * Fldr identifie a folder.  If the code accesses both Outlook and disc folders,
  '   the prefixes OutFldr and DscFldr are used instead.
  ' If the purpose of a variable does not fit within the above system, I use the
  ' name of the purpose for the variable.  For example DataMap.

  ' These constants identify which worksheet within this workbook holds the
  ' mapping table and its position within that worksheet.
  ' Cells(RowMapDataFirst, ColMapDataFirst) is the top left cell of the table
  ' excluding any column headings.
  ' Cells(RowMapDataFirst, ColMapDataFirst+1)
  ' ### Adjust as required.
  Const ColMapDataFirst As Long = 1
  Const RowMapDataFirst As Long = 2
  Const WshtDataName As String = "Data Mapping"

  ' Columns to the left of ColDestDataFirst and above RowDestDataFirst-1 are reserved.
  ' The data mapping table specifies the first destination column as 1. ColDestDataFirst
  ' specifies the true first destination column. When moving source columns to the
  ' destination worksheet, the destination column is adjusted for ColDestDataFirst.
  ' If at the start of this routine, the last row in the destination worksheet is less
  ' than RowDestDataFirst-1, the column headings will be written to RowDestDataFirst-1 and
  ' the first data will be written to RowDestDataFirst. If at the start of this routine,
  ' the last row in the destination worksheet is not less than RowDestDataFirst-1, the
  ' column headings will not be written to RowDestDataFirst-1 and the first data will be
  ' written to RowDestLast+1
  ' ### Adjust as required.
  Const ColDestDataFirst As Long = 3
  Const RowDestDataFirst As Long = 18
  Const WshtDestName As String = "Destination"

  ' First data row of a source worksheet.
  ' Note this code does not allow for source worksheets having different
  ' numbers of heding rows.
  Const RowSrcDataFirst As Long = 2

Sub CollectAndTransform()

  ' Collects data from all the source workbooks in the source folder and saves
  ' that data to the destination worksheet within this workbook.

  ' The Source folder is defined by FldrSrc.
  ' A source workbook is any workbook within FldrSrc that contains a worksheet which
  ' has all the required source columns.
  ' The data is saved by column with the new column sequence defined by the Data mapping
  ' table.
  ' The position of the Data mapping table is defined by ColDataDataFirst,
  ' RowDataDataFirst and WshtDataName.  See below where the data map is loaded to
  ' DataMap for more information. The format of the data map is defined at the top of
  ' sub DecodeMapping().

  ' 20Apr20  Coded.

  Dim ColDestCrnt As Long
  Dim ColDestLast As Long
  Dim ColsDestName() As String
  Dim ColSrcLast As Long
  Dim ColsSrcForDest() As Long
  Dim DataMap As Variant
  Dim Filename As String
  Dim FldrSrc As String
  Dim RngSrc As Range
  Dim RowDestLast As Long
  Dim RowMapLast As Long
  Dim RowSrcLast As Long
  Dim WbkSrc As Workbook
  Dim WbkThis As Workbook
  Dim WshtDest As Worksheet
  Dim WshtMap As Worksheet
  Dim WshtSrc As Worksheet

  Application.ScreenUpdating = False

  Set WbkThis = ThisWorkbook

  ' ### Replace by FldrSrc = "C:\Users\" & Environ(“UserName”) & "\Desktop\Test M" & "\"
  FldrSrc = ThisWorkbook.Path & "\"

  Set WshtMap = WbkThis.Worksheets("Data Mapping")
  Set WshtDest = WbkThis.Worksheets(WshtDestName)

  With WshtMap
    RowMapLast = .Cells(Rows.Count, 1).End(xlUp).Row
    DataMap = .Range(.Cells(RowMapDataFirst, 1), .Cells(RowMapLast, 2)).Value
    ' Note 1: the lower bounds of a variant loaded from a range are always one
    '         regardless of the location of the range within the worksheet.
    ' Note 2: I have loaded DataMap starting at row 2 because RowMapDataFirst
    '         equals 2.  If you want the table to start at a different row, just
    '         change the value of RowMapDataFirst.
  End With

  Filename = Dir$(FldrSrc & "*.xls*")
  Do While Filename <> "" And Filename <> ThisWorkbook.Name
    Set WbkSrc = Workbooks.Open(FldrSrc & Filename, , True)
    Set WshtSrc = FindSrcWsht(WbkSrc, DataMap)
    If WshtSrc Is Nothing Then
      Debug.Print WbkSrc.Name & " is is not a source workbook"
    Else
      ' This workkbook is a source workbook
      ' Call DecodeMapping here in case column sequence differs between workbooks.
      Call DecodeMapping(WshtSrc, DataMap, ColsDestName, ColsSrcForDest)
      If RowDestLast < RowDestDataFirst - 1 Then
        ' This is the first source workbook so the destination worksheet
        ' has not been checked
        Call FindLastRowCol(WshtDest, RowDestLast, ColDestLast)
        If RowDestLast < RowDestDataFirst - 1 Then
          ' No data has been written to the destination worksheet
          ' Output column headings
          With WshtDest
            .Range(.Cells(RowDestDataFirst - 1, ColDestDataFirst), _
                   .Cells(RowDestDataFirst - 1, ColDestDataFirst + _
                                                UBound(ColsDestName) - 1)).Value = ColsDestName
          End With
          RowDestLast = RowDestDataFirst - 1
        End If
      End If
      Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
      ' For each destination column which is not to be left empty,
      ' copy the appropriate source column to it.
      ' If ColDestCrnt(N) <> 0, source column ColDestCrnt(N) is to be copied
      ' to destination column N + ColDestDatFirst - 1
      ' A source column is from RowSrcDataFirst to RowSrcLast
      For ColDestCrnt = 1 To UBound(ColsSrcForDest)
        If ColsSrcForDest(ColDestCrnt) <> 0 Then
          With WshtSrc
            Set RngSrc = .Range(.Cells(RowSrcDataFirst, ColsSrcForDest(ColDestCrnt)), _
                                .Cells(RowSrcLast, ColsSrcForDest(ColDestCrnt)))
          End With
          Debug.Print WbkSrc.Name & "." & WshtSrc.Name & "Range("; RngSrc.Address & " ) -> " & _
                      WshtDest.Cells(RowDestLast + 1, ColDestCrnt + ColDestDataFirst - 1).Address
          RngSrc.Copy WshtDest.Cells(RowDestLast + 1, ColDestCrnt + ColDestDataFirst - 1)
        End If
      Next
      RowDestLast = RowDestLast + RngSrc.Rows.Count   ' Advance to bottom of data just copied
                                                      ' ready for next source workbook
    End If
    WbkSrc.Close
    Filename = Dir$
  Loop

  WshtDest.Columns.AutoFit

  Application.ScreenUpdating = True

End Sub
Sub DecodeMapping(ByRef WshtSrc As Worksheet, ByRef DataMap As Variant, _
                  ByRef ColsDestName() As String, ByRef ColsSrcForDest() As Long)

  ' Decodes a table mapping source column names to destination column names.

  ' Create an array of column headings for the destination worksheet.
  ' Locates the source column names within the source worksheet and creates an
  ' array mapping the source column numbers to the destination columns.

  ' WshtSrc        The source worksheet
  ' DataMap        A Variant holding a 2D table with 2 columns and 1 row per
  '                destination column.  Table column 1 contains the names of the
  '                destination columns in output sequence with table row N
  '                holding the name of destination column N.  Table column 2 of
  '                row N contains the name of the source column, if any, for the
  '                destination column whose name is in table column 1 or row N.
  ' ColsDestNames  On exit, the names of the destination columns in an array
  '                ready to be loaded to the header row of the destination
  '                worksheet.
  ' ColsSrcForDest On exit, ReDimmed to (1 To M) where M is the number of columns
  '                in the destination worksheet.  If ColsSrcForDest(P) = 0,
  '                destination column P is left blank.  If ColsSrcForDest(P) = Q,
  '                source column Q is to be copied to destination column P.

  ' 18Apr20  Coded.

  Dim ColSrcCrnt As Long
  Dim ColSrcLast As Long
  Dim Found As Boolean
  Dim RowMapCrnt As Long
  Dim RowSrcLast As Long

  ReDim ColsDestName(1 To UBound(DataMap, 1))

  ' Build array that can be used to create heading row for destination worksheet
  For RowMapCrnt = 1 To UBound(DataMap, 1)
    ColsDestName(RowMapCrnt) = DataMap(RowMapCrnt, 1)
  Next

  Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)  ' Only need ColSrcLast

  ' Size ColsSrcForDest so there is one entry per destination column
  ' The entries are initialised to zeros.
  ReDim ColsSrcForDest(1 To UBound(DataMap))

  ' There are faster methods of achieving the source to destination mapping
  ' than these nested loops but the VBA is more complicated.  If there are
  ' so many source and destination columns that this is slow, I will recode.
  ' Match each value in column 2 of DataMap against a column heading in
  ' worksheet WshtSrc.  When a match is found, record the match in ColsSrcForDest.
  With WshtSrc
    For RowMapCrnt = 1 To UBound(DataMap)
      If DataMap(RowMapCrnt, 2) <> "" Then
        'Debug.Assert False
        Found = False
        For ColSrcCrnt = 1 To ColSrcLast
          If .Cells(1, ColSrcCrnt).Value = DataMap(RowMapCrnt, 2) Then
            ' Warning: this a case sensitive match
            'Debug.Assert False
            ColsSrcForDest(RowMapCrnt) = ColSrcCrnt
            Found = True
            Exit For
          End If
        Next
        If Not Found Then
          Debug.Assert False
          Call MsgBox("Source column name """ & DataMap(RowMapCrnt, 2) & _
                      """ appears in the DataMap but is not a column " & _
                      "heading in worksheet """ & WshtSrc.Name & """", vbOKOnly)
          End     ' Exit this macro and calling macro.
        End If
      End If
    Next
  End With

End Sub
Function FindSrcWsht(ByRef WbkSrc As Workbook, ByRef DataMap As Variant) As Worksheet

  ' Return a reference to the worksheet within WbkSrc that has all the columns
  ' required by DataMap for a source worksheet.  Return Nothing if no such
  ' worksheet found.

  ' WbkSrc         A workbook that might be a source workbook
  ' DataMap        A Variant holding a 2D table with 2 columns and 1 row per
  '                destination column.  Table column 1 contains the names of the
  '                destination columns in output sequence with table row N
  '                holding the name of destination column N.  Table column 2 of
  '                row N contains the name of the source column, if any, for the
  '                destination column whose name is in table column 1 or row N.

  ' Column 1 of DataMap is not used by this routine.
  ' Column 2 of DataMap contains column names that must exist within a source
  ' worksheet.
  ' Workbook WbkSrc can contain one or more worksheets. Match the column names
  ' within each worksheet against the column names in column 2 of DataMap until
  ' a worksheet is found with all required columns.  Retun a reference to that
  ' worksheet.  Return Nothing if no satisfactory worksheet is found.

  ' 19Apr20  Coded

  Dim ColSrcCrnt As Long
  Dim ColSrcLast As Long
  Dim InxNR As Long
  Dim InxWsht As Long
  Dim MatchAll As Boolean
  Dim MatchSingleFound As Boolean
  Dim NamesRequired As Collection
  Dim RowMapCrnt As Long
  Dim RowSrcLast As Long

  Set NamesRequired = New Collection

  ' Create collection of the column names required in a worksheet
  For RowMapCrnt = 1 To UBound(DataMap, 1)
    If DataMap(RowMapCrnt, 2) <> "" Then
      NamesRequired.Add DataMap(RowMapCrnt, 2)
    End If
  Next

  With WbkSrc
    'Debug.Print .Name             ' Name of workbook
    ' For each worksheet, attempt match on every required name
    For InxWsht = 1 To .Worksheets.Count
      With .Worksheets(InxWsht)
        'Debug.Print "  " & .Name    ' Name of worksheet
        Call FindLastRowCol(WbkSrc.Worksheets(InxWsht), RowSrcLast, ColSrcLast)
        MatchAll = True   ' Assume all names matched until name not found
        For InxNR = 1 To NamesRequired.Count
          MatchSingleFound = False    ' Have not yet matched NamesRequired(InxNR)
          For ColSrcCrnt = 1 To ColSrcLast
            If .Cells(1, ColSrcCrnt).Value = NamesRequired(InxNR) Then
              ' Have a case sensitive match between required name and column heading
              'Debug.Assert False
              MatchSingleFound = True
              Exit For
            End If
          Next
          If Not MatchSingleFound Then
            ' NamesRequired(InxNR) not matched against any column heading
            'Debug.Assert False
            'Debug.Print "    Required name """ & NamesRequired(InxNR) & """ not found"
            MatchAll = False
          End If
        Next
        If MatchAll Then
          ' Every required name matched against this worksheet
          Set FindSrcWsht = WbkSrc.Worksheets(InxWsht)
          Exit Function
        End If
      End With
    Next
  End With

  ' If get here, none of the worksheets contains every required name
  Set FindSrcWsht = Nothing

End Function

Answer 2

Разработка и тестирование возможного решения

Я бы никогда не попытался спроектировать и закодировать подобную процедуру в одном go. Я бы разделил это на шаги; и я буду кодировать и тестировать эти шаги отдельно, если это возможно. У вас есть блок кода, который не работает. Была ли ошибка в шаге 1 или шаге 5? Я также ищу возможности написать свой код в виде подпрограмм или функций, которые я смогу использовать снова.

Рассмотрим Function FindLastRow. Вы закодировали эту функцию таким образом, чтобы она была уникальной для этого проекта. Поиск последней строки и / или столбца на рабочем листе является частым требованием, поэтому было бы полезно создать блок кода, который вы можете использовать снова и снова.

Вы использовали метод поиска последней строки столбца, который это, пожалуй, самый надежный метод, при котором вы знаете, какую колонку тестировать. Вы избежали «какой столбец?» Проблема проверена в каждой колонке. Существуют и другие методы поиска последнего ряда, но ни один из доступных методов не работает в каждой ситуации. Мое решение состояло в том, чтобы написать процедуру, которая использовала несколько методов и выбрала «лучший» ответ. Я не волнуюсь, какая техника будет лучшей или самой быстрой для сегодняшнего рабочего листа; Я просто использую свою стандартную рутину. Подпрограмма для сегодняшнего сценария может быть быстрее, но у меня нет времени для программистов, которые тратят минуты на написание кода, который экономит миллисекунды от подпрограммы, которая запускается раз в день.

Это моя подпрограмма для поиска последней строки и столбца рабочего листа:

Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not.
  ' I had known the Find would miss merged cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value about that found by Find

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible?
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible?
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   * Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub

Эта процедура была написана мной для меня. Я рад поделиться этим, но это не было написано, чтобы поделиться. Блок комментариев в верхней части достаточно стандартен для моих подпрограмм: что он делает, каковы параметры, почему и история. Структура будет варьироваться в зависимости от сложности процедуры и от того, сколько времени мне понадобилось, чтобы заставить ее работать правильно. Эта процедура имеет несколько комментариев в теле макроса. Рассмотрим первый блок, в котором я использую Range.Find для получения последней строки и столбца. Какой комментарий поможет понять этот блок? Если я забыл синтаксис для Range.Find, быстрый онлайн-поиск покажет страницу, которая объясняет это. Осталось несколько Debug.Assert False. Они предназначены для выявления ситуаций, в которых я не верю, что это может произойти, но о которых я хочу знать, если они это сделают. У меня есть модули с именами, такими как LibExcel, LibOutlook и LibOffice, которые содержат подпрограммы, указывающие c для Excel (например, этот) или Outlook, или подпрограммы, полезные для нескольких пакетов Office (например, чтение и запись файлов). Поскольку они находятся в PERSONAL.XLSB, они доступны для всех моих рабочих книг. Если вы хотите узнать больше, поищите в сети PERSONAL.XLSB.

Я бы разделил вашу проблему на три этапа:

1. Найдите каждый файл в целевой папке один за другим.
2. Расшифруйте таблицу сопоставления столбцов.
3. Примените сопоставление столбцов к текущему файлу.

Вы можете разделить свою проблему по-разному; это будет зависеть от того, насколько вам удобно с программированием в VBA. Я использую VBA в течение 18 лет, и я выучил свой первый язык программирования 55 лет go, поэтому я чувствую себя комфортно, хотя я никогда не думал о себе как о гике; для меня программирование - это всего лишь средство для достижения цели.

Я бы не подумал о превращении Dir l oop в подпрограмму, возвращающую коллекцию. Для меня использование Dir для поиска по одной папке настолько просто, что я никогда не удосужился создать для нее подпрограмму. Поиск по подпапкам делает l oop более сложным, но для меня недостаточно последовательным, чтобы превратиться в подпрограмму. Декодирование таблицы сопоставления столбцов зависит от того, как она будет использоваться. Это означает, что я должен сначала разработать шаг 3.

Копирование всего диапазона в вариант за один go намного, намного быстрее, чем копирование ячейки с помощью клетка. Однако копирование из одной ячейки массива в другую происходит не намного быстрее, чем копирование одной ячейки таблицы в другую. Я бы использовал Range.Copy, чтобы скопировать весь столбец источника на лист назначения. То есть я скопировал бы исходный столбец 1 в целевой столбец 2, 2–3, 6–6, 5–7, 4–8, 3–9 и 5–10.

Чтобы сделать копирование простым, Мне нужна эта информация в массиве или, возможно, в паре массивов. Мой выбор ограничен необходимостью скопировать исходный столбец 5 в целевые столбцы 7 и 10. Моя лучшая идея:

Array Index       | 1| 2| 3| 4| 5| 6| 7| 8| 9|10|
SrcForDest        | 2| 3| 9| 8| 7| 6| 0| 0| 0| 5|

Индекс массива идентифицирует целевой столбец. Значение 0 означает, что столбец не имеет источника. Любое другое значение является исходным столбцом. L oop становится:

For Inx = 1 to 10
  If SrcForDest(Inx) <> 0 Then
    Construct source range
    Construct destination range
    Copy
  End If
Next

Часть 2

Я хотел написать код и протестировать макрос DecodeMapping(). Я создал книгу с поддержкой макросов. В нем я создал рабочие листы «Отображение данных», «Источник» и «Место назначения». Я знаю, что «Источник» и «Место назначения» - это не имя, которое вы используете, но в настоящее время это просто книга для тестирования.

Я ввел вашу таблицу отображения данных в таблицу «Отображение данных»:

Если я правильно понял, у вас есть название вашей целевой таблицы в качестве ячейки A1 этой рабочей таблицы. Я думаю, что это плохая идея. Я предполагаю, что вы пытаетесь объединить множество существующих рабочих книг в одну новую рабочую книгу. Это будет однократное преобразование, и вам никогда не придется снова просматривать этот макрос после завершения преобразования. Мне не нравится ничего, что не очевидно, потому что я видел, что это вызывает катастрофы, когда новый программист не понимал, почему ячейка A1 имела это странное значение. Если вы называете рабочий лист чем-то вроде контрольных данных и четко обозначаете имя рабочего листа и четко обозначаете таблицу сопоставления, тогда все в порядке. Но называть таблицу «Отображение данных», но иметь в ячейке А1 что-то еще - плохая практика. Я избегаю плохой практики, даже если это не имеет значения, потому что это становится привычкой. Однако, как я объясню позже, это не имеет значения.

Я ввел заголовки столбцов в таблицу «Источник»:

Нет данных, потому что на данном этапе мне не нужны никакие данные.

Рабочий лист «Место назначения» я оставил пустым.

Я создал три модуля, которые я назвал: «LibExcel», «Mod Original» и «ModNew». Я скопировал макрос FindLastRowCol в модуль «LibExcel». Я скопировал ваш код в «ModOriginal», чтобы на него было легко ссылаться. Я написал макросы DecodeMapping и TestDecodeMapping в «ModNew».

Это техника, которую я часто использую. Для проверки DecodeMapping я создаю тестовый макрос, имитирующий возможную настройку. Мне не нужно беспокоиться ни о чем, кроме потребностей DecodeMapping.

Код в модуле «ModNew»:

Option Explicit
Sub TestDecodeMapping()

  Const RowMapDataFirst As Long = 2

  Dim ColDestCrnt As Long
  Dim ColsDestName() As String
  Dim ColsSrcForDest() As Long
  Dim DataMap As Variant
  Dim RowMapLast As Long
  Dim WshtMap As Worksheet
  Dim WshtSrc As Worksheet

  Set WshtMap = Worksheets("Data Mapping")
  Set WshtSrc = Worksheets("Source")

  With WshtMap
    RowMapLast = .Cells(Rows.Count, 1).End(xlUp).Row
    DataMap = .Range(.Cells(RowMapDataFirst, 1), .Cells(RowMapLast, 2)).Value
    ' Note 1: the lower bounds of a variant loaded from a range are always one
    '         regardless of the location of the range within the worksheet.
    ' Note 2: I have loaded DataMap starting at row 2 because RowMapDataFirst
    '         equals 2.  If you want the table to start at a different row, just
    '         change the value of RowMapDataFirst.
  End With

  Call DecodeMapping(WshtSrc, DataMap, ColsDestName, ColsSrcForDest)

  ' Test ColsDestName by loading it to the top row of worksheet "Destination."
  With Worksheets("Destination")
    .Range(.Cells(1, 1), .Cells(1, UBound(ColsDestName))).Value = ColsDestName
  End With

  ' Test ColsSrcForDest by outoutting an anotated list of its contents.
  For ColDestCrnt = 1 To UBound(ColsSrcForDest)
    Debug.Print "Destination column " & ColDestCrnt & " (" & DataMap(ColDestCrnt, 1) & _
                ") ";
    If ColsSrcForDest(ColDestCrnt) = 0 Then
      Debug.Print "will be left empty"
    Else
      Debug.Print "will be loaded from source column " & ColsSrcForDest(ColDestCrnt) & _
                  " (" & DataMap(ColDestCrnt, 2) & ")"
    End If
  Next

End Sub
Sub DecodeMapping(ByRef WshtSrc As Worksheet, ByRef DataMap As Variant, _
                  ByRef ColsDestName() As String, ByRef ColsSrcForDest() As Long)

  ' Decodes a table mapping source column names to destination column names.

  ' Create an array of column headings for the destination worksheet.
  ' Locates the source column names within the source worksheet and creates an
  ' array mapping the source column numbers to the destination columns.

  ' WshtSrc        The source worksheet
  ' DataMap        A Variant holding a 2D table with 2 columns and 1 row per
  '                destination column.  Table column 1 contains the names of the
  '                destination columns in output sequence with table row N
  '                holding the name of destination column N.  Table column 2 of
  '                row N contains the name of the source column, if any, for the
  '                destination column whose name is in table column 1 or row N.
  ' ColsDestNames  On exit, the names of the destination columns in an array
  '                ready to be loaded to the header row of the destination
  '                worksheet.
  ' ColsSrcForDest On exit, ReDimmed to (1 To M) where M is the number of columns
  '                in the destination worksheet.  If ColsSrcForDest(P) = 0,
  '                destination column P is left blank.  If ColsSrcForDest(P) = Q,
  '                source column Q is to be copied to destination column P.

  ' 18Apr20  Coded.

  Dim ColSrcCrnt As Long
  Dim ColSrcLast As Long
  Dim Found As Boolean
  Dim RowDataCrnt As Long
  Dim RowSrcLast As Long

  ReDim ColsDestName(1 To UBound(DataMap, 1))

  ' Build array that can be used to create heading row for destination worksheet
  For RowDataCrnt = 1 To UBound(DataMap, 1)
    ColsDestName(RowDataCrnt) = DataMap(RowDataCrnt, 1)
  Next

  Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)  ' Only need ColSrcLast

  ' Size ColsSrcForDest so there is one entry per destination column
  ' The entries are initialised to zeros.
  ReDim ColsSrcForDest(1 To UBound(DataMap))

  ' There are faster methods of achieving the source to destination mapping
  ' than these nested loops but the VBA is more complicated.  If there are
  ' so many source and destination columns that this is slow, I will recode.
  ' Match each value in column 2 of DataMap against a column heading in
  ' worksheet WshtSrc.  When a match is found, record the match in ColsSrcForDest.
  With WshtSrc
    For RowDataCrnt = 1 To UBound(DataMap)
      If DataMap(RowDataCrnt, 2) <> "" Then
        'Debug.Assert False
        Found = False
        For ColSrcCrnt = 1 To ColSrcLast
          If .Cells(1, ColSrcCrnt).Value = DataMap(RowDataCrnt, 2) Then
            ' Warning: this a case sensitive match
            'Debug.Assert False
            ColsSrcForDest(RowDataCrnt) = ColSrcCrnt
            Found = True
            Exit For
          End If
        Next
        If Not Found Then
          Debug.Assert False
          Call MsgBox("Source column name """ & DataMap(RowDataCrnt, 2) & _
                      """ appears in the DataMap but is not a column " & _
                      "heading in worksheet """ & WshtSrc.Name & """", vbOKOnly)
          End     ' Exit this macro and calling macro.
        End If
      End If
    Next
  End With

End Sub

Примечания:

• Макро TestDecodeMapping () делает всю подготовку. Загружает вариант DataMap с рабочего листа. DecodeMapping () не знает, как DataMap был создан. Если вы хотите загрузить DataMap из нижнего рабочего листа «Отображение данных», никаких изменений не потребуется, чтобы DecodeMapping ()
• DecodeMapping не выполняло никаких смещений. Смещение должно быть в основной программе, так что это очевидно. Нас учили: никаких скрытых побочных эффектов. Если новый программист берет на себя программу, все должно быть очевидно. Если подпрограмма называется DoX, она должна выполнять X и ничего больше.
• Посмотрите, как я проверяю вывод DecodeMapping (). Я хочу быть на 100% уверенным в том, что DecodeMapping () работает правильно, прежде чем использовать его в своей основной программе.
• Я считаю, что я включил достаточно комментариев, чтобы вы могли понять мой код, но задавайте вопросы по мере необходимости.

Часть 3

Следующая проблема - найти исходные рабочие книги и проверить исходные рабочие таблицы.

Вы предполагаете, что каждый файл в пределах "C : \ Users \ "& Environ (« Имя пользователя ») &« \ Desktop \ Test M »- это исходная рабочая книга. Поскольку вы управляете содержимым этой папки, это может быть разумным предположением, если только рабочая книга, содержащая макросы и конечный лист, также не находится в этой папке.

Вы предполагаете, что исходная рабочая таблица всегда является Sheet (1) и что каждая рабочая таблица содержит каждый исходный столбец. Опять же, это могут быть разумные предположения, но ваш макрос потерпит неудачу, если хотя бы одна исходная книга будет не совсем такой, как вы предполагаете. Я не знаю, сколько существует этих рабочих книг, поскольку ваш вопрос подразумевает, что есть только одна. Это функция LoopThroughFiles(), которая указывает на наличие нескольких исходных рабочих книг. Если вы контролируете эти рабочие книги, вы можете знать, что они все одинаковые. Но если кто-то контролирует их, любое предположение опасно. Легко добавить другой рабочий лист в рабочую книгу по проекту или случайно.

Я написал функцию FindSrcWsht(), которая не делает никаких предположений, и я написал Sub TestFindSrcWsht(), чтобы протестировать ее и продемонстрировать, как я буду найдите и проверьте эти рабочие книги.

Я создал пять рабочих книг, которые соответствуют моему пониманию ваших исходных рабочих книг. У некоторых есть дополнительные столбцы, у некоторых есть столбцы в другой последовательности, и у некоторых есть пропущенные столбцы. Вам не нужно создавать тестовые рабочие тетради, поскольку у вас есть настоящие.

В начале TestFindSrcWsht() вы найдете Path = ThisWorkbook.Path & "\". Вам нужно заменить это на Path = "C:\Users\" & Environ(“UserName”) & "\Desktop\Test M" & "\". Кроме того, я считаю, что макросы будут работать без изменений. Вывод будет выглядеть примерно так:

Test Data 1.xlsx
  Source
  This is a source workbook
Test Data 2.xlsx
  Sheet1
    Required name "Trans qty" not found
    Required name "Name" not found
    Required name "Color" not found
    Required name "Name" not found
  Source
  This is a source workbook
Test Data 3.xlsx
  Sheet1
    Required name "Style no" not found
    Required name "Item number" not found
    Required name "Trans qty" not found
    Required name "Name" not found
    Required name "Color" not found
    Required name "Size" not found
    Required name "Name" not found
  Sheet2
    Required name "Style no" not found
    Required name "Item number" not found
    Required name "Trans qty" not found
    Required name "Name" not found
    Required name "Color" not found
    Required name "Size" not found
    Required name "Name" not found
  Source
  This is a source workbook
Test Data 4.xlsx
  Source
    Required name "Name" not found
    Required name "Name" not found
  This is not a source workbook
Test Data 5.xlsx
  Source
    Required name "Style no" not found
  This is not a source workbook

Новый код:

Sub TestFindSrcWsht()

  Const RowMapDataFirst As Long = 2

  Dim DataMap As Variant
  Dim Filename As String
  Dim Path As String
  Dim RowMapLast As Long
  Dim WbkSrc As Workbook
  Dim WshtMap As Worksheet

  Application.ScreenUpdating = False

  Set WshtMap = Worksheets("Data Mapping")

  With WshtMap
    RowMapLast = .Cells(Rows.Count, 1).End(xlUp).Row
    DataMap = .Range(.Cells(RowMapDataFirst, 1), .Cells(RowMapLast, 2)).Value
    ' Note 1: the lower bounds of a variant loaded from a range are always one
    '         regardless of the location of the range within the worksheet.
    ' Note 2: I have loaded DataMap starting at row 2 because RowMapDataFirst
    '         equals 2.  If you want the table to start at a different row, just
    '         change the value of RowMapDataFirst.
  End With

  Path = ThisWorkbook.Path & "\"

  Filename = Dir$(Path & "*.xls*")
  Do While Filename <> "" And Filename <> ThisWorkbook.Name
    Set WbkSrc = Workbooks.Open(Path & Filename, , True)
    If FindSrcWsht(WbkSrc, DataMap) Is Nothing Then
      Debug.Print "  This is not a source workbook"
    Else
      Debug.Print "  This is a source workbook"
    End If
    WbkSrc.Close
    Filename = Dir$
  Loop

  Application.ScreenUpdating = True

End Sub
Function FindSrcWsht(ByRef WbkSrc As Workbook, ByRef DataMap As Variant) As Worksheet

  ' Return a reference to the worksheet within WbkSrc that has all the columns
  ' required by DataMap for a source worksheet.  Return Nothing if no such
  ' worksheet found.

  ' WbkSrc         A workbook that might be a source workbook
  ' DataMap        A Variant holding a 2D table with 2 columns and 1 row per
  '                destination column.  Table column 1 contains the names of the
  '                destination columns in output sequence with table row N
  '                holding the name of destination column N.  Table column 2 of
  '                row N contains the name of the source column, if any, for the
  '                destination column whose name is in table column 1 or row N.

  ' Column 1 of DataMap is not used by this routine.
  ' Column 2 of DataMap contains column names that must exist within a source
  ' worksheet.
  ' Workbook WbkSrc can contain one or more worksheets. Match the column names
  ' within each worksheet against the column names in column 2 of DataMap until
  ' a worksheet is found with all required columns.  Retun a reference to that
  ' worksheet.  Return Nothing if no satisfactory worksheet is found.

  ' 19Apr20  Coded

  Dim ColSrcCrnt As Long
  Dim ColSrcLast As Long
  Dim InxNR As Long
  Dim InxWsht As Long
  Dim MatchAll As Boolean
  Dim MatchSingleFound As Boolean
  Dim NamesRequired As Collection
  Dim RowDataCrnt As Long
  Dim RowSrcLast As Long

  Set NamesRequired = New Collection

  ' Create collection of the column names required in a worksheet
  For RowDataCrnt = 1 To UBound(DataMap, 1)
    If DataMap(RowDataCrnt, 2) <> "" Then
      NamesRequired.Add DataMap(RowDataCrnt, 2)
    End If
  Next

  With WbkSrc
    Debug.Print .Name             ' Name of workbook
    ' For each worksheet, attempt match on every required name
    For InxWsht = 1 To .Worksheets.Count
      With .Worksheets(InxWsht)
        Debug.Print "  " & .Name    ' Name of worksheet
        Call FindLastRowCol(WbkSrc.Worksheets(InxWsht), RowSrcLast, ColSrcLast)
        MatchAll = True   ' Assume all names matched until name not found
        For InxNR = 1 To NamesRequired.Count
          MatchSingleFound = False    ' Have not yet matched NamesRequired(InxNR)
          For ColSrcCrnt = 1 To ColSrcLast
            If .Cells(1, ColSrcCrnt).Value = NamesRequired(InxNR) Then
              ' Have a case sensitive match between required name and column heading
              'Debug.Assert False
              MatchSingleFound = True
              Exit For
            End If
          Next
          If Not MatchSingleFound Then
            ' NamesRequired(InxNR) not matched against any column heading
            'Debug.Assert False
            Debug.Print "    Required name """ & NamesRequired(InxNR) & """ not found"
            MatchAll = False
          End If
        Next
        If MatchAll Then
          ' Every required name matched against this worksheet
          Set FindSrcWsht = WbkSrc.Worksheets(InxWsht)
          Exit Function
        End If
      End With
    Next
  End With

  ' If get here, none of the worksheets contains every required name
  Set FindSrcWsht = Nothing

End Function