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]

Ok, you only want to see the active people in the table. I think I follow you now.

 

[Nena99]

I tested the macro on dummy workbooks using the data you posted and it worked exactly as you requested. Perhaps you could upload copies of your two files to a free site such as www.box.com or www.dropbox.com. Once you do that, mark each file for 'Sharing' and you will be given a link to each file that you can post here (de-sensitized if necessary).

It was in the begining give me an error with line ( .Cells(1).CurrentRegion.AutoFilter 4, "Active") but when it worked it gave me some results.

It does work on the example, however because my file is 10 columns and 20000 rows, I think the code needs a bit update
Would you please add report missing cells in the table?
And sum of the TotalLeft?

 

[mumps]

I won’t be able to help any further until you upload copies of your files as I have previously requested.

 

[Nena99]

Ok, this will only pick Active.

Option Explicit
Sub forCompareDataOnTwoWorkbooks()

    Dim wbs1 As Workbook: Set wbs1 = Workbooks("mainData.xlsm")
    Dim wbs3 As Workbook: Set wbs3 = Workbooks("transferData.xlsm")
   
    Dim mws1 As Worksheet: Set mws1 = wbs1.Worksheets("Sheet1")
    Dim mws3 As Worksheet: Set mws3 = wbs3.Worksheets("Sheet1")
  
    Dim cell1 As Range, rng1 As Range, lastRow1 As Long
    Dim cell3 As Range, rng3 As Range, lastRow3 As Long
   
    lastRow1 = mws1.Cells(Rows.Count, "B").End(xlUp).Row
    lastRow3 = mws3.Cells(Rows.Count, "C").End(xlUp).Row
   
    Set rng1 = mws1.Range("B2:B" & lastRow1)
    Set rng3 = mws3.Range("C2:C" & lastRow3)

    For Each cell1 In rng1
        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
End Sub

Great, thank you.
Are you able to add Sum of " Total Left", and if you could report any missing values?

 

[DacEasy]

The below will add a third workbook so the original data is not touched. It will also delete rows without an Active status. I will look at Total Left now.

Option Explicit
Sub forCompareDataOnTwoWorkbooks()
    Application.DisplayAlerts = False
    
    On Error Resume Next
    Workbooks("newly_Created.xlsm").Close   'The below will create this workbook but it must be closed
    
    Workbooks.Add
    Dim MyDocsPath
    MyDocsPath = Environ$("USERPROFILE") & "\" & "Documents\newly_Created.xlsm"
    ActiveWorkbook.SaveAs Filename:= _
        MyDocsPath, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        
    Dim wbs1 As Workbook: Set wbs1 = Workbooks("newly_Created.xlsm")
    Dim wbs2 As Workbook: Set wbs2 = Workbooks("mainData.xlsm")
    Dim wbs3 As Workbook: Set wbs3 = Workbooks("transferData.xlsm")
    
    Dim mws1 As Worksheet: Set mws1 = wbs1.Worksheets("Sheet1")
    Dim mws2 As Worksheet: Set mws2 = wbs2.Worksheets("Sheet1")
    Dim mws3 As Worksheet: Set mws3 = wbs3.Worksheets("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, "B").End(xlUp).Row
    lastRow3 = mws3.Cells(Rows.Count, "C").End(xlUp).Row
    
    Set rng1 = mws1.Range("B2:B" & lastRow1)
    Set rng3 = mws3.Range("C2:C" & lastRow3)
    
    mws2.Columns("A:I").Copy mws1.Range("a1")
    
    For Each cell1 In rng1
        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
            If LCase(mws1.Range("F" & i).Value) <> LCase("Active") Then
                Rows(i).Delete
            End If
    Next i
    
    Application.DisplayAlerts = True
End Sub

 

[DacEasy]

Actually, explain this better, I don't follow you:

1. Are you able to add Sum of " Total Left" - What is the formula for this
2. Report any missing values? - What values

 

[Nena99]

Actually, explain this better, I don't follow you:

1. Are you able to add Sum of " Total Left" - What is the formula for this
2. Report any missing values? - What values

If you look at the table that I provided, you will see Workbook 2, at number 1 there is an empty cell for Total Left, so the code should be able to report that in a seperate file that the whole row is empty. Also, I am not working on 4 rows only, I am working on 10000 rows to keep in mind.
The sum of Total left is (sum=cell1+cell2+cell3....)

I really appreciate your help

 

[Nena99]

The below will add a third workbook so the original data is not touched. It will also delete rows without an Active status. I will look at Total Left now.

Option Explicit
Sub forCompareDataOnTwoWorkbooks()
    Application.DisplayAlerts = False
  
    On Error Resume Next
    Workbooks("newly_Created.xlsm").Close   'The below will create this workbook but it must be closed
  
    Workbooks.Add
    Dim MyDocsPath
    MyDocsPath = Environ$("USERPROFILE") & "\" & "Documents\newly_Created.xlsm"
    ActiveWorkbook.SaveAs Filename:= _
        MyDocsPath, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
      
    Dim wbs1 As Workbook: Set wbs1 = Workbooks("newly_Created.xlsm")
    Dim wbs2 As Workbook: Set wbs2 = Workbooks("mainData.xlsm")
    Dim wbs3 As Workbook: Set wbs3 = Workbooks("transferData.xlsm")
  
    Dim mws1 As Worksheet: Set mws1 = wbs1.Worksheets("Sheet1")
    Dim mws2 As Worksheet: Set mws2 = wbs2.Worksheets("Sheet1")
    Dim mws3 As Worksheet: Set mws3 = wbs3.Worksheets("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, "B").End(xlUp).Row
    lastRow3 = mws3.Cells(Rows.Count, "C").End(xlUp).Row
  
    Set rng1 = mws1.Range("B2:B" & lastRow1)
    Set rng3 = mws3.Range("C2:C" & lastRow3)
  
    mws2.Columns("A:I").Copy mws1.Range("a1")
  
    For Each cell1 In rng1
        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
            If LCase(mws1.Range("F" & i).Value) <> LCase("Active") Then
                Rows(i).Delete
            End If
    Next i
  
    Application.DisplayAlerts = True
End Sub

I tried your code, but it does not bring any values back. Not for the data I provided nor for my file. It does create new file but nothing in it

 

[Nena99]

I won’t be able to help any further until you upload copies of your files as I have previously requested.

It is exactly the same data as the one I provided. Your code works fine for the example, but when I apply it on 10000 rows, it does not look for the ID, meaning for the example it brings total left but for the actual data it doesnt.
Also, Thank you very much for your time, I really appreciate your try to help

 

[DacEasy]

Dim wbs2 As Workbook: Set wbs2 = Workbooks("mainData.xlsm")
Dim wbs3 As Workbook: Set wbs3 = Workbooks("transferData.xlsm")

Make sure you update the two lines above with the right file names. wbs2 is the data with all the columns

Option Explicit
Sub forCompareDataOnTwoWorkbooks()
    Application.DisplayAlerts = False
    
    On Error Resume Next
    Workbooks("newly_Created.xlsm").Close   'The below will create this workbook but it must be closed
    
    Workbooks.Add
    Dim MyDocsPath
    MyDocsPath = Environ$("USERPROFILE") & "\" & "Documents\newly_Created.xlsm"
    ActiveWorkbook.SaveAs Filename:= _
        MyDocsPath, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        
    Dim wbs1 As Workbook: Set wbs1 = Workbooks("newly_Created.xlsm")
    Dim wbs2 As Workbook: Set wbs2 = Workbooks("mainData.xlsm")
    Dim wbs3 As Workbook: Set wbs3 = Workbooks("transferData.xlsm")
    
    Dim mws1 As Worksheet: Set mws1 = wbs1.Worksheets("Sheet1")
    Dim mws2 As Worksheet: Set mws2 = wbs2.Worksheets("Sheet1")
    Dim mws3 As Worksheet: Set mws3 = wbs3.Worksheets("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, "B").End(xlUp).Row
    lastRow3 = mws3.Cells(Rows.Count, "C").End(xlUp).Row
    
    Set rng1 = mws1.Range("B2:B" & lastRow1)
    Set rng3 = mws3.Range("C2:C" & lastRow3)
    
    mws2.Columns("A:I").Copy mws1.Range("a1")
    
    For Each cell1 In rng1
        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
            If LCase(mws1.Range("F" & i).Value) <> LCase("Active") Then
                Rows(i).Delete
            End If
    Next i
    
    lastRow1 = mws1.Cells(Rows.Count, "B").End(xlUp).Row
    mws1.Range("H" & lastRow1 + 1).Value = "=SUM(H2:H" & lastRow1 & ")"
    
    
    Application.DisplayAlerts = True
End Sub