Copy data from a variable table - excel

Question

I have been trying to do a report and creating a macro to copy the data from one file to another.
I cannot figure out how to copy the data since the table I need to get my data from varies.
Example one:
What I need to copy is what is below the Alarm text.
But in, example one, I have no critical alarms but there are files that may have. Same applies to major/minor/warning.
The max of lines below the Alarm text are 3, but I can have 1/2/3 or even none.
In example 2, I have no data.
Here I have 2 critical and 3 on all other categories.
I know this may be a weird question, but I have no idea in how to find the these values, since they may vary so much.
All help is appreciated
Here is the code i have, but i am missing the important part,
Sub Copy()
Dim wbOpen As Workbook
Dim wbMe As Workbook
Dim vals As Variant
Set wbMe = ThisWorkbook
Set wbOpen = Workbooks.Open("C:\XXX\Core")
'MSS
vals = wbOpen.Sheets("MSS02NZF").Range("A2:B260").Copy
wbMe.Sheets("MSS02NZF").Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' wbOpen.Sheets(1).Range("A2:B260").Copy
' wbMe.Sheets(1).Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'MME
vals = wbOpen.Sheets("MME01NZF").Range("A2:H260").Copy
wbMe.Sheets("MME01NZF").Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'CSCF
vals = wbOpen.Sheets("CSCF").Range("A2:H2060").Copy
wbMe.Sheets("CSCF").Range("B5").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Answer 1

Modify to your own need; code is using A:B as your source, and pastes the results in C:D.
Sub test()
Dim lrow As Long, alarmRow() As Long, alarmEnd() As Long
Dim count As Long, count2 As Long, rowcount As Long
ReDim alarmRow(1 To Application.CountIf(Range("A:A"), "Alarm"))
ReDim alarmEnd(1 To UBound(alarmRow))
With Worksheets("Sheet4") 'Change this to the Sheetname of your source.
lrow = .Cells(Rows.count, 1).End(xlUp).Row
For x = 1 To lrow Step 1
If .Range("A" & x).Value = "Alarm" Then 'Change "A" column to where your source data is.
count = count + 1
alarmRow(count) = x + 1
ElseIf .Range("A" & x).Value = "" Then 'Change "A" column to where your source data is.
count2 = count2 + 1
alarmEnd(count2) = x
End If
alarmEnd(UBound(alarmEnd)) = lrow
Next
For x = 1 To UBound(alarmRow) Step 1
lrow = .Cells(Rows.count, 3).End(xlUp).Row + 1
rowcount = alarmEnd(x) - alarmRow(x)
.Range("C" & lrow & ":D" & lrow + rowcount).Value = .Range("A" & alarmRow(x) & ":B" & alarmEnd(x)).Value ' Change A/B to where your source data is, and C/D to where you want to put the list.
Next
End With
End Sub
It's a bit of a mess, but here's how it works:
It'll look at the list where the word "Alarm" is. Once it finds it, the row number the word is in is registered to an Array. The row of the blank space is also taken to another array. This will serve as the range when copying the data.

Answer 2

Array of Arrays feat. 3-dimensional Jagged Arrays
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
'*******************************************************************************