Array of Arrays 壮举。 3维交错数组
Option Explicit
'*******************************************************************************
' Purpose: If not open, opens a specified workbook and pastes specific data
' found in two columns from several worksheets into a range specified
' by a cell in worksheets with the same name in this workbook.
'*******************************************************************************
Sub CopyPasteArray()
'***************************************
' List of Worksheet Names in Both Workbooks
Const cStrWsName As String = "MSS02NZF,MME01NZF,CSCF"
' Separator in List of Names of Worksheets in Both Workbooks
Const cStrSplit As String = ","
' Path of Workbook to Be Copied From
Const cStrSourcePath As String = "C:\XXX"
' Name of Workbook to Be Copied From
Const cStrSourceName As String = "Core.xls"
' Address of First Row Range to Be Copied From
Const cStrSourceFirst As String = "A2:B2"
' Target Top Cell Address to Be Pasted Into
Const cStrTopCell As String = "B5"
' Search String
Const cStrSearch As String = "Alarm"
' Target Columns
Const cIntTargetCols As Integer = 2 ' Change to 3 to include Type of Error.
'***************************************
Dim objWbSource As Workbook ' Source Workbook
Dim vntWsName As Variant ' Worksheet Names Array
Dim vntSourceAA As Variant ' Source Array of Arrays
Dim vntTargetAA As Variant ' Target Array of Arrays
Dim vntTargetRows As Variant ' Each Target Array Rows Array
Dim vntTarget As Variant ' Each Target Array
Dim blnFound As Boolean ' Source Workbook Open Checker
Dim lngRow As Long ' Source Array Arrays Rows Counter
Dim intCol As Integer ' Source Array Arrays Columns Counter
Dim intArr As Integer ' Worksheets and Arrays Counter
Dim lngCount As Long ' Critical Data Counter
Dim lngCount2 As Long ' Critical Data Next Row Counter
Dim strPasteCell As String
'***************************************
' Paste list of worksheets names into Worksheet Names Array.
vntWsName = Split(cStrWsName, cStrSplit)
'***************************************
' Check if Source Workbook is open.
For Each objWbSource In Workbooks
If objWbSource.Name = cStrSourceName Then
Set objWbSource = Workbooks(cStrSourceName)
blnFound = True ' Workbook is open.
Exit For ' Stop checking.
End If
Next
' If Source Workbook is not open, open it.
If blnFound = False Then
Set objWbSource = Workbooks.Open(cStrSourcePath & "\" & cStrSourceName)
End If
'***************************************
' Paste data from Source Workbook into Source Array of Arrays.
ReDim vntSourceAA(UBound(vntWsName))
For intArr = 0 To UBound(vntWsName)
With objWbSource.Worksheets(vntWsName(intArr))
vntSourceAA(intArr) = _
.Range( _
.Range(cStrSourceFirst).Cells(1, 1) _
, .Cells( _
.Range( _
.Cells(1, .Range(cStrSourceFirst).Column) _
, .Cells(Rows.Count, .Range(cStrSourceFirst).Column _
+ .Range(cStrSourceFirst).Columns.Count - 1)) _
.Find(What:="*", _
After:=.Range(cStrSourceFirst).Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious _
).Row _
, .Range(cStrSourceFirst).Column _
+ .Range(cStrSourceFirst).Columns.Count - 1 _
) _
).Value2
End With
Next
' The Source Array of Arrays is a 3-dimensional (jagged) array containing
' a 0-based 1-dimensional array containing an 'UBound(vntWsName)' number of
' 1-based 2-dimensional arrays.
'***************************************
' Count the number of critical data rows to determine size
' of each Target Array.
ReDim vntTargetRows(UBound(vntWsName))
For intArr = 0 To UBound(vntSourceAA)
For lngRow = 1 To UBound(vntSourceAA(intArr), 1)
If vntSourceAA(intArr)(lngRow, 1) = cStrSearch Then
For lngCount2 = lngRow + 1 To UBound(vntSourceAA(intArr), 1)
If vntSourceAA(intArr)(lngCount2, 1) <> "" Then
' Debug.Print vntSourceAA(intArr)(lngCount2, 1)
lngCount = lngCount + 1
lngRow = lngRow + 1
Else
Exit For
End If
Next
End If
Next
vntTargetRows(intArr) = lngCount
lngCount = 0
Next
'***************************************
' Copy critical data into each Target Array and paste it into
' Target Array of Arrays.
ReDim vntTargetAA(UBound(vntWsName))
For intArr = 0 To UBound(vntSourceAA)
ReDim vntTarget(1 To vntTargetRows(intArr), 1 To cIntTargetCols)
For lngRow = 1 To UBound(vntSourceAA(intArr), 1)
If vntSourceAA(intArr)(lngRow, 1) = cStrSearch Then
If cIntTargetCols = 3 Then
lngCount = lngCount + 1
vntTarget(lngCount, 1) = vntSourceAA(intArr)(lngRow - 1, 1)
lngCount = lngCount - 1
End If
For lngCount2 = lngRow + 1 To UBound(vntSourceAA(intArr), 1)
If vntSourceAA(intArr)(lngCount2, 1) <> "" Then
' Debug.Print vntSourceAA(intArr)(lngCount2, 1)
lngCount = lngCount + 1
vntTarget(lngCount, cIntTargetCols - 1) _
= vntSourceAA(intArr)(lngCount2, 1)
vntTarget(lngCount, cIntTargetCols) _
= vntSourceAA(intArr)(lngCount2, 2)
lngRow = lngRow + 1
Else
Exit For
End If
Next
End If
Next
vntTargetAA(intArr) = vntTarget
lngCount = 0
Next
'***************************************
' Clean up
Erase vntTarget
Erase vntTargetRows
Erase vntSourceAA
'***************************************
' Paste each Target Array into each of this workbook's worksheet's ranges,
' which are starting at the specified cell (cStrTopCell) if no data is below,
' or else at the first empty cell found searching from the bottom.
For intArr = 0 To UBound(vntWsName)
With ThisWorkbook.Worksheets(vntWsName(intArr))
If .Cells(Rows.Count, .Range(cStrTopCell).Column + cIntTargetCols - 2) _
.End(xlUp).Row = 1 Then
' No data in column
strPasteCell = cStrTopCell
Else
' Find first empty cell searching from bottom.
strPasteCell = _
.Cells( _
.Range( _
.Cells(1, .Range(cStrTopCell).Column) _
, .Cells(Rows.Count, .Range(cStrTopCell).Column _
+ cIntTargetCols - 1)) _
.Find(What:="*", _
After:=.Range(cStrTopCell).Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious _
).Row + 1 _
, .Range(cStrTopCell).Column _
).Address
' First empty cell is above Target Top Cell Address.
If Range(strPasteCell).Row < Range(cStrTopCell).Row Then _
strPasteCell = cStrTopCell
End If
' Paste into range.
.Range(strPasteCell).Resize( _
UBound(vntTargetAA(intArr)) _
, _
UBound(vntTargetAA(intArr), 2) _
) = vntTargetAA(intArr)
End With
Next
'***************************************
' Clean up
Erase vntTargetAA
Erase vntWsName
Set objWbSource = Nothing
End Sub
'*******************************************************************************