Imports rows from multiple sheets of a workbook into final sheet along with their wrap text, width, height, alignments and ...
Also import any pictures found in column D of these sheets
Built specially for a project here recently
Destination workbook has to be open prior to run this macro, so macro is expecting to have only 1 additional workbook open within same Excel session.
Columns to be imported are 9 columns, A through K, modify to add more if needed
Sub ConcaUFO_RowsfromSheets()
Dim Wb as Workbook ' Workbook to search for matching rows
Dim TotSh ' Total sheet to be created in destination workbook to have total rows matching 'Fail' condition
StA1 = "A1" ' Starting cell in Total sheet
GetStatus = "Fail" ' Condition to import from rows accross all sheets
TotSh = "Total" ' Name of output sheet
WidthDone = 0 ' To import width of columns, needed only once for each column
On Error Resume Next
TotName = Wb.Worksheets(TotSh).Name
If Err.Number < > 0 Then
' We do not have the sheet yet, create it
Wb.Worksheets.Add Wb.Worksheets(1) ' Create it as first sheet
Wb.ActiveSheet.Name = TotSh
Else
' We already have it, clear it
Wb.Worksheets(TotSh).Range(StA1).EntireColumn.EntireRow.Clear
Wb.Worksheets(TotSh).Activate
End If
Wb.Worksheets(TotSh).Range(StA1).Offset(5).Activate
ActiveWindow.FreezePanes = True
Wb.Worksheets(TotSh).Range(StA1).Value = TotSh
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 0).Value = "Sheet" ' A
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 1).Value = "Row" ' B
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 2).Value = "S. No" ' C
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 3).Value = "Checkpoint" ' D
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 4).Value = "WCAG 2.1"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 5).Value = "Test Status"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 6).Value = "Test Result"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 7).Value = "Severity" ' H
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 8).Value = "Screenshots"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 9).Value = "Guideline/Checkpoint Level"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 10).Value = "Comments" ' K
Wb.Worksheets(TotSh).Range(StA1).EntireColumn.EntireRow.WrapText = False ' resetting wrapping text
X1 = 4 ' Starting to import into cell A4
For Each Shh in Wb.Worksheets ' Loop through all sheets
If Shh.Range("A4").Value < > "URL" Then Goto NextShh ' Only import sheets having text "URL" in cell A4
X2 = 12 ' Starting from Row 13 in each sheet
Do ' Loop through all rows in sheet until a space is found
X2 = X2 + 1
Status1 = Shh.Range("D" & X2).Value
If UCase(Status1) = UCase(GetStatus) Then ' Import row if column D = GetStatus above text
Gosub AddLine 'Actually import the row along with its objects if found in Column D of it
End If
Loop Until Status1 = ""
NextShh:
Next
Goto ByeBye
AddLine:
X1 = X1 + 1 ' Line Offset
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 0).Value = ShhName ' From which sheet did we import it
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 1).Value = X2 ' What row
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 0).VerticalAlignment = xlVAlignTop ' Alignement
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 0).WrapText = True ' Wrap text
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 1).VerticalAlignment = xlVAlignTop ' More alignment
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 1).HorizontalAlignment = xlHAlignCenter ' Horizontal alignment
For I = 1 To 9 ' Import the next 9 columns as they are
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).Value = Shh.Range("A" & X2).Offset(, I - 1).Value
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).WrapText = Shh.Range("A" & X2).Offset(, I - 1).WrapText
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).HorizontalAlignment = _
Shh.Range("A" & X2).Offset(, I - 1).HorizontalAlignment
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).VerticalAlignment = _
Shh.Range("A" & X2).Offset(, I - 1).VerticalAlignment
If WidthDone = 0 Then
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).EntireColumn.ColumnWidth = _
Shh.Range("A" & X2).Offset(, I - 1).EntireColumn.ColumnWidth
End If
Next
' Prepare to import objects
WidthDone = 1 ' Reset variable to import column width
BoxesPerCell = 0 ' Reset variable to import objects if more than 1 found in that column
RowHeight = Shh.Range("A" & X2).Top ' The top of that row to look for objects
RowBottom = Shh.Range("A" & X2 + 1).Top ' The bottom of that row to look for objects between those boundaries
For Each Objj In Shh.Shapes ' Loop through all objects in that sheet
If Objj.Top >= RowHight And Objj.Top <= RowBottom Then ' Is this object falls between top and bottom of that row?
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Select
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Value = Objj.Name ' Bring object name to confirm that we do have an object here
Objj.Copy ' Copy object
DoEvents
Wb.Worksheets(TotSh).Paste ' Paste it into this sheet
Doevents
Selection.Left = Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Left + BoxesPerCell ' Move it to Column F, equvelant to Source Sheet column D
Selection.Top = Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Top
BoxesPerCell = BoxesPerCell + 60
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Select
End If
Next
Return
ByeBye:
On Error Goto 0
Set Wb = Nothing
End Sub
Dim Wb as Workbook ' Workbook to search for matching rows
Dim TotSh ' Total sheet to be created in destination workbook to have total rows matching 'Fail' condition
StA1 = "A1" ' Starting cell in Total sheet
GetStatus = "Fail" ' Condition to import from rows accross all sheets
TotSh = "Total" ' Name of output sheet
WidthDone = 0 ' To import width of columns, needed only once for each column
On Error Resume Next
TotName = Wb.Worksheets(TotSh).Name
If Err.Number < > 0 Then
' We do not have the sheet yet, create it
Wb.Worksheets.Add Wb.Worksheets(1) ' Create it as first sheet
Wb.ActiveSheet.Name = TotSh
Else
' We already have it, clear it
Wb.Worksheets(TotSh).Range(StA1).EntireColumn.EntireRow.Clear
Wb.Worksheets(TotSh).Activate
End If
Wb.Worksheets(TotSh).Range(StA1).Offset(5).Activate
ActiveWindow.FreezePanes = True
Wb.Worksheets(TotSh).Range(StA1).Value = TotSh
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 0).Value = "Sheet" ' A
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 1).Value = "Row" ' B
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 2).Value = "S. No" ' C
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 3).Value = "Checkpoint" ' D
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 4).Value = "WCAG 2.1"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 5).Value = "Test Status"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 6).Value = "Test Result"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 7).Value = "Severity" ' H
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 8).Value = "Screenshots"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 9).Value = "Guideline/Checkpoint Level"
Wb.Worksheets(TotSh).Range(StA1).Offset(4, 10).Value = "Comments" ' K
Wb.Worksheets(TotSh).Range(StA1).EntireColumn.EntireRow.WrapText = False ' resetting wrapping text
X1 = 4 ' Starting to import into cell A4
For Each Shh in Wb.Worksheets ' Loop through all sheets
If Shh.Range("A4").Value < > "URL" Then Goto NextShh ' Only import sheets having text "URL" in cell A4
X2 = 12 ' Starting from Row 13 in each sheet
Do ' Loop through all rows in sheet until a space is found
X2 = X2 + 1
Status1 = Shh.Range("D" & X2).Value
If UCase(Status1) = UCase(GetStatus) Then ' Import row if column D = GetStatus above text
Gosub AddLine 'Actually import the row along with its objects if found in Column D of it
End If
Loop Until Status1 = ""
NextShh:
Next
Goto ByeBye
AddLine:
X1 = X1 + 1 ' Line Offset
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 0).Value = ShhName ' From which sheet did we import it
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 1).Value = X2 ' What row
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 0).VerticalAlignment = xlVAlignTop ' Alignement
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 0).WrapText = True ' Wrap text
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 1).VerticalAlignment = xlVAlignTop ' More alignment
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 1).HorizontalAlignment = xlHAlignCenter ' Horizontal alignment
For I = 1 To 9 ' Import the next 9 columns as they are
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).Value = Shh.Range("A" & X2).Offset(, I - 1).Value
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).WrapText = Shh.Range("A" & X2).Offset(, I - 1).WrapText
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).HorizontalAlignment = _
Shh.Range("A" & X2).Offset(, I - 1).HorizontalAlignment
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).VerticalAlignment = _
Shh.Range("A" & X2).Offset(, I - 1).VerticalAlignment
If WidthDone = 0 Then
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, I + 1).EntireColumn.ColumnWidth = _
Shh.Range("A" & X2).Offset(, I - 1).EntireColumn.ColumnWidth
End If
Next
' Prepare to import objects
WidthDone = 1 ' Reset variable to import column width
BoxesPerCell = 0 ' Reset variable to import objects if more than 1 found in that column
RowHeight = Shh.Range("A" & X2).Top ' The top of that row to look for objects
RowBottom = Shh.Range("A" & X2 + 1).Top ' The bottom of that row to look for objects between those boundaries
For Each Objj In Shh.Shapes ' Loop through all objects in that sheet
If Objj.Top >= RowHight And Objj.Top <= RowBottom Then ' Is this object falls between top and bottom of that row?
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Select
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Value = Objj.Name ' Bring object name to confirm that we do have an object here
Objj.Copy ' Copy object
DoEvents
Wb.Worksheets(TotSh).Paste ' Paste it into this sheet
Doevents
Selection.Left = Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Left + BoxesPerCell ' Move it to Column F, equvelant to Source Sheet column D
Selection.Top = Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Top
BoxesPerCell = BoxesPerCell + 60
Wb.Worksheets(TotSh).Range(StA1).Offset(X1, 8).Select
End If
Next
Return
ByeBye:
On Error Goto 0
Set Wb = Nothing
End Sub
Views 899
Downloads 247
CodeID
DB ID
ANmarAmdeen
602
Revisions
v1.0
Wednesday
November
11
2020