VBA Create a table from two different workbooks based on Active status and report missing data or errors

[Nena99]

I want to merge two tables from two different workbooks and that is what I managed to do so far.
The code I have is good to look for the rows that have active in them but it keeps empty rows in between the new table. Meaning, ID 1 and 4 are active but there is two rows non active and unknown so it wont copy them and I will have similar to the picture
Could someone help me to add a line so it does not leave an empty rows?

**Also I would like to add a line so it look for the ID in another table and copy the row and bring it to the new table.

**There are errors in the line (4 Stevens) so how can I make it report it back to me that there is error?

Option Explicit

Sub Test()

Dim Cell As Range

With Sheets(1)
   ' loop column H untill last cell with value (not entire column)
   For Each Cell In .Range("G1:G" & .Cells(.Rows.Count, "H").End(xlUp).Row)
       If Cell.Value = "Active" Then
            ' Copy>>Paste in 1-line (no need to use Select)
           .Rows(Cell.Row).Copy Destination:=Sheets(4).Rows(Cell.Row)
           
       End If
   Next Cell
End With

End Sub

 

[DacEasy]

I wonder if you are able to provide me with a link or tips how you craeted the macro for both?

I gave you two macros. I will paste them separately so you can see them better.

1.

Option Explicit
Sub forCompareDataOnTwoWorkbooks()
    Application.ErrorCheckingOptions.BackgroundChecking = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error Resume Next
    Workbooks("newly_Created.xlsm").Close   'The below will create this workbook, but first it must be closed
    
    Workbooks.Add
    Dim MyDocsPath
    MyDocsPath = Environ$("USERPROFILE") & "\" & "Documents\newly_Created.xlsm"
    ActiveWorkbook.SaveAs Filename:= _
        MyDocsPath, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    
    Dim mws1 As Worksheet: Set mws1 = Workbooks("newly_Created.xlsm").Sheets("Sheet1")
    Dim mws2 As Worksheet: Set mws2 = Workbooks("mainData.xlsm").Sheets("Sheet1")
    Dim mws3 As Worksheet: Set mws3 = Workbooks("transferData.xlsm").Sheets("Sheet1")
   
    Dim cell1 As Range, rng1 As Range, lastRow1 As Long
    Dim cell3 As Range, rng3 As Range, lastRow3 As Long
    
    lastRow1 = mws2.Cells(Rows.Count, "A").End(xlUp).Row
    lastRow3 = mws3.Cells(Rows.Count, "A").End(xlUp).Row
    
    Set rng1 = mws1.Range("A2:A" & lastRow1)
    Set rng3 = mws3.Range("A2:A" & lastRow3)
    
    mws2.Columns("A:I").Copy mws1.Range("a1")       'Copy data from mainData.xlsm to newly_Created.xlsm
    
    For Each cell1 In rng1                          'Fills in Totalleft if the names match and they are Active
        For Each cell3 In rng3
        With cell1
            If cell1.Value = cell3.Value And LCase(mws1.Range("F" & cell1.Row).Value) = LCase("Active") Then
                
                mws1.Range("H" & cell1.Row).Value = mws3.Range("D" & cell3.Row).Value
                
            End If
        End With
        Next cell3
    Next cell1
    
    Dim i As Long                                   'To delete rows, start from the bottom and work up
    For i = lastRow1 To 2 Step -1                   'Rows missing "Active" in any case are deleted
            If LCase(mws1.Range("F" & i).Value) <> LCase("Active") Then
                Rows(i).Delete
            End If
    Next i
        
    Application.ErrorCheckingOptions.BackgroundChecking = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[DacEasy]

2.

Sub ToCreateLogFile()
    Application.ErrorCheckingOptions.BackgroundChecking = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim cell1 As Range, rng1 As Range, lastRow1 As Long
    
    On Error Resume Next
    Dim mws1 As Worksheet: Set mws1 = Workbooks("newly_Created.xlsm").Sheets("Sheet1")
        
    If mws1 Is Nothing Then
        Exit Sub
    End If
    
    lastRow1 = mws1.Cells(Rows.Count, "A").End(xlUp).Row
    Set rng1 = mws1.Range("A2:A" & lastRow1)
    
    'Totals column H
    mws1.Range("H" & lastRow1 + 1).Value = "=SUM(H2:H" & lastRow1 & ")"
    
    'The below writes the rows missing a Totalleft value to \Documents\missingDataFile.txt
    Dim logFile As String, myString As String, FN As Byte
    Dim myDate As String, myTime As String
    
    myDate = Format(Date, "dd MMM yyyy")
    myTime = Format(Time, "hh:mm:ss")
    logFile = Environ$("USERPROFILE") & "\" & "Documents\missingDataFile.txt"
    
    mws1.Cells.Select
    Selection.Replace What:="#N/A", Replacement:="N/A", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
        
    FN = 1
    Open logFile For Append As #FN
    
    'Active and missing column B
    Print #FN, vbCr & "Missing column B or N/A"
    For Each cell1 In rng1
        With cell1
            If cell1.Offset(0, 1).Value = "" Or cell1.Offset(0, 1).Value = "N/A" Then
                 myString = "Row - " & cell1.Row & ":" & vbTab & cell1.Offset(0, 0).Value & vbTab & _
                  cell1.Offset(0, 1).Value & vbTab & cell1.Offset(0, 2).Value & vbTab & _
                  cell1.Offset(0, 3).Value & vbTab & cell1.Offset(0, 4).Value & vbTab & _
                  cell1.Offset(0, 5).Value & vbTab & cell1.Offset(0, 6).Value & vbTab & vbTab & cell1.Offset(0, 7).Value
                 
                 Print #FN, myString
            End If
        End With
    Next cell1
    
    'Active and missing column G
    Print #FN, vbCr & "Missing column G or N/A"
    For Each cell1 In rng1
        With cell1
            If cell1.Offset(0, 6).Value = "" Or cell1.Offset(0, 6).Value = "N/A" Then
                 myString = "Row - " & cell1.Row & ":" & vbTab & cell1.Offset(0, 0).Value & vbTab & _
                  cell1.Offset(0, 1).Value & vbTab & cell1.Offset(0, 2).Value & vbTab & _
                  cell1.Offset(0, 3).Value & vbTab & cell1.Offset(0, 4).Value & vbTab & _
                  cell1.Offset(0, 5).Value & vbTab & cell1.Offset(0, 6).Value & vbTab & vbTab & cell1.Offset(0, 7).Value
                 
                 Print #FN, myString
            End If
        End With
    Next cell1
    
    'Active and missing column H
    Print #FN, vbCr & "Missing column H"
    For Each cell1 In rng1
        With cell1
            If cell1.Offset(0, 7).Value = "" Then
                 myString = "Row - " & cell1.Row & ":" & vbTab & cell1.Offset(0, 0).Value & vbTab & _
                  cell1.Offset(0, 1).Value & vbTab & cell1.Offset(0, 2).Value & vbTab & _
                  cell1.Offset(0, 3).Value & vbTab & cell1.Offset(0, 4).Value & vbTab & _
                  cell1.Offset(0, 5).Value & vbTab & cell1.Offset(0, 6).Value & vbTab & vbTab & cell1.Offset(0, 7).Value
                 
                 Print #FN, myString
            End If
        End With
    Next cell1
    
    Print #FN, "Closing......" & myDate & "  " & myTime 'adding "Closing", so you can better see the changes each time you run.
    Close #FN
    
    Application.ErrorCheckingOptions.BackgroundChecking = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[Nena99]

Thank you ?