ConcaUFO_RowsfromSheets

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


Public

Tested

My Own Work
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

Views 115 Downloads 31

VBA-Excel Layout+Design
ANmarAmdeen
763
Attachments
Revisions

v1.0