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

N

Nena99

New Member
Joined
Apr 7, 2022
Messages
28
Office Version
  1. 2021
Platform
  1. Windows
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?

VBA Code: 
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
 

Attachments

  • Screenshot 2022-04-07 152813.png
    Screenshot 2022-04-07 152813.png
    13.3 KB · Views: 14
  • Screenshot 2022-04-08 132604.png
    Screenshot 2022-04-08 132604.png
    4.5 KB · Views: 15
  • Screenshot 2022-04-08 132826.png
    Screenshot 2022-04-08 132826.png
    6.7 KB · Views: 14
Last edited by a moderator:
Sort by date Sort by votes
DacEasy said:
You may want to add tabs in the text file for better formatting. If you do, replace the other myString with the one beelow:

VBA Code: 
                myString = "Row - " & cell1.Row & ":" & vbTab & cell1.Offset(0, -1).Value & 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
Click to expand...
I will let you know tonight as I have to run to the doctor. Thank you very much for all your help, you are amazing.
 
Upvote 0

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
DacEasy said:
You may want to add tabs in the text file for better formatting. If you do, replace the other myString with the one beelow:

VBA Code: 
                myString = "Row - " & cell1.Row & ":" & vbTab & cell1.Offset(0, -1).Value & 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
Click to expand...
This line worked, thank you very much. I am getting the same results as yours.
I have a question is the search base on the ID number or based on the name? If it is based on the name then that what was causing me errors as some rows do not have names in them, as I need the search based on the ID.
I am really sorry for troubling you, but would you please be able to modify it to take the search based on the ID?
 
Last edited:
Upvote 0
It is now based on ID instead of Name:

VBA Code: 
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
    
    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
    logFile = Environ$("USERPROFILE") & "\" & "Documents\missingDataFile.txt"
    
    FN = 1
    Open logFile For Append As #FN
    
    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
                 
                 Print #FN, myString
            End If
        End With
    Next cell1
    
    Print #FN, "Closing......"  '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
 
Last edited:
Upvote 0
DacEasy said:
It is now based on ID instead of Name:

VBA Code: 
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
 
    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
    logFile = Environ$("USERPROFILE") & "\" & "Documents\missingDataFile.txt"
 
    FN = 1
    Open logFile For Append As #FN
 
    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
            
                 Print #FN, myString
            End If
        End With
    Next cell1
 
    Print #FN, "Closing......"  '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
Click to expand...
You are amazing and I am really thankful for your help. I wish you all the best and may God bless you.
 
Last edited:
Upvote 0
DacEasy said:
It is now based on ID instead of Name:

VBA Code: 
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
   
    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
    logFile = Environ$("USERPROFILE") & "\" & "Documents\missingDataFile.txt"
   
    FN = 1
    Open logFile For Append As #FN
   
    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
                
                 Print #FN, myString
            End If
        End With
    Next cell1
   
    Print #FN, "Closing......"  '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
Click to expand...
I wonder if you could do me one more favor because you are Excel wizard?
I am going to remove the report section from the code and run it as a seperate code. But I am looking for every empty cell in the table and every #N/A in the table.
The report file should be the same that you created earlier but it will be seperated based on reporting every column.
So, if column B is missing cell 4 for example, it should bring back the whole row. If column C is good then it will skip it. If column G has an empty cell or #N/A it should report column G and bring back the whole row and etc.
The report will look like


Column B
Row - 2: 1 15/12/1972 AA01 15/12/1982 Active AB1 1AA 0.1
Row - 3: 2 06/04/1973 AA02 06/04/1983 Active AB1 1AA 0.2
Row - 4: 3 27/08/1977 AA03 27/08/1987 Active AB1 1AA 0.3

Column G
Row - 5: 4 DD 30/04/2001 AA05 30/04/2011 Active 0.4
Row - 6: 5 EE 02/01/1998 AA06 02/01/2008 Active #N/A 0.5
Row - 7: 6 FF 15/10/1989 AA07 15/10/1999 Active 0.6

Column H (missing values at the end)
Row - 8: 7 GG 15/06/1991 AA09 14/06/2001 Active AB1 1AA
Row - 9: 8 HH 26/12/2005 AA013 26/12/2015 Active AB1 1AA
 
Upvote 0
Alright here you go. Just so you know, VBA doesn't handle words that begin with '#' well, so the macro does a find and replace to change "#N/A" to "N/A". If you must have it say "#N/A", find the code that does the find and replace and copy it at the end and reverse the two words, and it will change it back.

VBA Code: 
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
    
    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 & 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 & 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 & 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
 

Attachments

  • finalFMD.jpg
    finalFMD.jpg
    65.6 KB · Views: 7
Upvote 0
Thank you very much, would you please split it to its own code? The code will check the (newly_created) file only

DacEasy said:
Alright here you go. Just so you know, VBA doesn't handle words that begin with '#' well, so the macro does a find and replace to change "#N/A" to "N/A". If you must have it say "#N/A", find the code that does the find and replace and copy it at the end and reverse the two words, and it will change it back.

VBA Code: 
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
  
    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 & 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 & 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 & 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
Click to expand...
 
Last edited:
Upvote 0
Here you go:

VBA Code: 
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


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
 
Upvote 0
Solution
You are
DacEasy said:
Here you go:

VBA Code: 
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


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
Click to expand...
you are amazing, thank you very much.
 
Upvote 0
DacEasy said:
Ok this will write the missing rows to a log file in you mydocument folder.

VBA Code: 
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 & ")"                 'Totals the column H
   
    Dim logFile As String, myString As String, FN As Byte                               'The below writes the missing rows to a logfile
    logFile = Environ$("USERPROFILE") & "\" & "Documents\missingDataFile.txt"
   
    FN = 1
    Open logFile For Append As #FN
   
    For Each cell3 In rng3
        With cell3
            If cell3.Offset(0, 1).Value = "" Then
                myString = "Row - " & cell3.Row & "    " & cell3.Offset(0, -2).Value & "    " & cell3.Offset(0, -1).Value & "    " & cell3.Offset(0, 0).Value & "    " & cell3.Offset(0, 1).Value
                Print #FN, myString
            End If
        End With
    Next cell3
   
    Print #FN, "Closing"  'adding Closing, so you can better see the changes each time you run.
    Close #FN
   
    Application.DisplayAlerts = True
End Sub
Click to expand...
I wonder if you are able to provide me with a link or tips how you craeted the macro for both?
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
Move multiple rows from one table to another using conditional trigger
Replies
2
Views
466
ItsNursinTime
I
B
  • Question
Add new Row in ListObject Table with data from an Array
Replies
4
Views
85
Akuini
Akuini
P
  • Solved
select rows that match current active cell vba issue
Replies
5
Views
230
Legacy 143009
L
C
  • Question
Delete Cell Range, or Add Range and Copy Formulas etc. - Excel VBA
Replies
0
Views
62
CSTjr
C
M
  • Question
VBA Code to copy rows by date from one tab to another / repeat based on new date
Replies
3
Views
221
kevin9999
K

Forum statistics

Threads
1,214,885
Messages
6,122,090
Members
449,065
Latest member
Danger_SF

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top