Excel 如何在数组VBA中跳过列
我有一个源工作簿和目标工作簿，希望将所有数据从源wb映射到目标wb，但列根据映射按特定顺序排列。源标题和目标标题都可以是任意长度，但重要的是目标标题，因为我不想返回所有数据，只需要基于映射需要的数据 我陷入了需要偏移列的循环中，因为当我写入目标wb时，它会一列接一列地写入，这不是我想要的。因此，如果映射中有空，则将该列保留为空，并移动到下一列。当将该列写入工作簿时，数组应具有相同的列数，但数据位于正确的位置。任何帮助都将不胜感激，因为我尝试了各种方法，但总是以错误的数据或根本不起作用而告终。下面的方法可以工作，但在写入数据时，它不会跳过映射中没有的内容，因此我需要手动更改列以适应正确列中的正确数据，也可以进行复制和粘贴，但我认为数组在执行此任务时会快得多，因为数据的行数超过300k行 这张图片是从不同的表格中拼凑而成的，不会有黄色的行，这是为了明确哪些数据属于哪些数据。映射第一行的数据将具有工作表名称，我将在其中写入数据Excel 如何在数组VBA中跳过列,excel,vba,Excel,Vba,我有一个源工作簿和目标工作簿，希望将所有数据从源wb映射到目标wb，但列根据映射按特定顺序排列。源标题和目标标题都可以是任意长度，但重要的是目标标题，因为我不想返回所有数据，只需要基于映射需要的数据 我陷入了需要偏移列的循环中，因为当我写入目标wb时，它会一列接一列地写入，这不是我想要的。因此，如果映射中有空，则将该列保留为空，并移动到下一列。当将该列写入工作簿时，数组应具有相同的列数，但数据位于正确的位置。任何帮助都将不胜感激，因为我尝试了各种方法，但总是以错误的数据或根本不起作用而告终。下
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
选项显式
子数据转换（）
将wsDataMapping设置为工作表
将目标设置为工作表
将sourceWB设置为工作簿
将targetWB设置为工作簿
作为范围的映射
Dim destMappingCell作为范围
将数据作为范围
将数据设置为范围
Dim srcArr作为变体
Dim destArr（）作为变量
暗淡的LCol尽可能长
我想我会坚持多久
Dim j尽可能长
暗x等长
暗光源与长光源一样低
将目标行变暗为长
将剩余文件设置为字符串
变暗时间
时间=现在（）
Application.ScreenUpdating=False
设置targetWeb=ActiveWorkbook
与targetWB
设置wsDataMapping=.Sheets（“数据映射”）
设置targetWS=.Sheets（wsDataMapping.Range（“A1”）.value）
以
LCol=targetWS.Cells（16，targetWS.Columns.Count）.End（xlToLeft）.Column
设置destMapping=wsDataMapping.Range（“A2:A”和wsDataMapping.Range（“A”和wsDataMapping.Rows.Count）。End（xlUp）。Row）
将文件路径设置为字符串
变暗文件名作为变量
将所有文件设置为集合
Set allFiles=新集合
filePath=“C:\Users\”环境（“用户名”）和“\Desktop\Test M”和“\”
'fileName=Dir（文件路径&“***”）
设置allFiles=LoopThroughFiles（文件路径，“.*”）
对于所有文件中的每个文件名
设置sourceWB=Workbooks.Open（文件路径和文件名）
设置srcData=sourceWB.Worksheets（1）.Range（“A1”）.CurrentRegion
设置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
TARGETROW=FindLastRow（targetWS，3，LCol）
如果（targetWS.Rows.Count-targetLRow）>sourceLRow，则
srcArr=srcData.value
ReDim保留解除绑定（1到UBound（srcArr，1），1到UBound（srcArr，2））
对于destMapping中的每个destMapping单元
x=0
对于i=LBound（srcArr，2）到UBound（srcArr，2）
如果destMappingCell.Offset（0，1）.value=srcArr（1，i），则
x=x+1
对于j=LBound（srcArr，1）到UBound（srcArr，1）
'Debug.Print srcArr（j，i）
destArr（j，x）=srcArr（j，i）
下一个j
如果结束
接下来我
下一个映射单元
sourceWB.Close错误
targetWS.Range（“C”和targetRow）.调整大小（UBound（destArr，1），UBound（destArr，2））。值=destArr
否则
sourceWB.Close为False
remainingFiles=remainingFiles&“”&fileName&vbNewLine
如果结束
下一个文件名
Application.ScreenUpdating=True
MsgBox time&“运行后”&Now（）&vbNewLine&“要处理的剩余文件是”&vbNewLine&remainingFiles
端接头
函数LoopThroughFiles（inputDirectoryToScanForFile、filenameCriteria）作为集合
作为字符串的Dim strFile
将文件名设置为集合
设置文件名=新集合
strFile=Dir（inputDirectoryToScanForFile&“\*”&filenameCriteria）
当Len（strFile）>0时执行
'Debug.Print strFile
文件名。添加（strFile）
strFile=Dir'返回一个新文件
环路
设置LoopThroughFiles=文件名
端函数
函数FindLastRow（ByVal ws作为工作表，可选ByVal FromCol作为Long=0，可选ByVal ToCol作为Long=0）作为Long
我想我会坚持多久
最后一排一样长
如果FromCol=0，则FromCol=3
如果ToCol=0，则ToCol=10
对于i=从COL到ToCol
lastRow=ws.Cells（ws.Rows.Count，i）.End（xlUp）.Row
如果FindLastRowPublic 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
Array Index | 1| 2| 3| 4| 5| 6| 7| 8| 9|10|
SrcForDest | 2| 3| 9| 8| 7| 6| 0| 0| 0| 5|
For Inx = 1 to 10
If SrcForDest(Inx) <> 0 Then
Construct source range
Construct destination range
Copy
End If
Next
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
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
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