VBA code consolidate worksheets excluding formula "blanks"

[JKWyo]

Seems like I'm the company's Excel and Access guy, but my knowledge of them is only google search deep...

I have a workbook to track assignments that will be updated by six people. I've done something similar in the past at a different job and I cannot for the life of me find the macro that I had used. Thanks to several hours of google searching, I found one that combines each workers sheet into the reports sheet- but now I am stuck at having it ignore the cells that contain a function returned "" value. The function (in column A) is set to return a value (mid,day,swing) based on another cells value. I am having problems with identifying the last row excluding the "blanks". I'm combining the worksheets in order to create pivot tables. The top rows are going to be reserved for instructions, so the data will start in A8.

Here is the working code so far:

Sub CopyRangeFromMultiWorksheets()    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim last As Long
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Reports").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Reports"
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name And sh.Name <> "Categories" And sh.Name <> "Activity Sheet" And sh.Name <> "Macro Sheet" Then
[COLOR=#FF0000]            Set CopyRng = sh.Range("A1").CurrentRegion[/COLOR]
            If last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If
            CopyRng.Copy
            With DestSh.Cells(last + 1, "A")
                .PasteSpecial xlPasteValues
[COLOR=#FF0000]                .PasteSpecial xlPasteFormats[/COLOR]
                Application.CutCopyMode = False
            End With
            DestSh.Cells(last + 1, "I").Resize(CopyRng.Rows.Count).Value = sh.Name
        End If
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Function LastRow(sh As Worksheet)
    On Error Resume Next
        LastRow = Columns("A").Find(What:="*", _
        After:=sh.Range("A*"), _
        Lookat:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
        After:=sh.Range("A8"), _
        Lookat:=xlPart, _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Column
    On Error GoTo 0
  End Function

My previous consolidate code, I identified the sheets that I wanted to include, vice listing the sheets that I want to exclude. I also think that I didnt have to delete and create the destination sheet every time. Two of my columns are formatted for mm/dd and hh:mm:ss, and the consolidate doesn't format the destination cells to match for some reason. I'll have to work on that later.

After 7 hours trying to google search a solution, trial and error, I gave up. I'm going to request they send me to an Excel/ Access class if they keep requesting these things from me.

So, to recap, how can I get the macro to skip the blank cells when it copies the last row when it copies the worksheets into the one?
what line do I need to get it to copy the mm/dd and hh/mm/ss format?

Thanks in advance!

 

[Kamolga]

What about

ActiveSheet.Range("A:A").AutoFilter Field:=1, Criteria1:= _
        "<>"

?

 

[Kamolga]

Otherwise an easy trick is to hide each line where value in column A is "", copy the visible lines only and paste them where you want to.

Sub Test()




Dim i As Long


i = 8                               'or whatever line you want it to start




Rows(i).EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
                                                                        
       
Do While Application.WorksheetFunction.CountA(Selection) <> 0
        If Cells(i, 1).Value = "" Then
        Rows(i).EntireRow.Hidden = True
           End If
               
i = i + 1
Rows(i).EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Loop
                                    'Choose the range to copy
Range("A8").CurrentRegion.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

you can unhide the rows when pasted if you want to

Cells.EntireRow.Hidden = False

 

[JKWyo]

Thanks for the reply- I think I entered the activesheet.range in the right place but keep getting run time errors. It also gives character error if I leave the underscore. I did a little searching added some criteria thinking that it could help, but still get an error.

Sub CopyRangeFromMultiWorksheets()    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim last As Long
    Dim activesheet As Worksheet
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Reports").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Reports"
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name And sh.Name <> "Categories" And sh.Name <> "Activity Sheet" And sh.Name <> "Macro Sheet" Then
          Set CopyRng = sh.Range("A8").CurrentRegion
          activesheet.Range("A:A").AutoFilter Field:=3, Criteria1:=Array("MID", "DAY", "SWG"), Operator:=xlFilterValues
            If last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If
            CopyRng.Copy
            With DestSh.Cells(last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
            DestSh.Cells(last + 1, "I").Resize(CopyRng.Rows.Count).Value = sh.Name
        End If
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Function LastRow(sh As Worksheet)
    On Error Resume Next
        LastRow = Columns("A").Find(What:="*", _
        After:=sh.Range("A*"), _
        Lookat:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
        After:=sh.Range("A8"), _
        Lookat:=xlPart, _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Column
    On Error GoTo 0
  End Function