Excel VBA needed to do data comparison from 2 excel files and generate an separate output file

[vinoanbu]

Hi,
Could any one help on this.
I'm working with two excel files "File 1"and "File 2". I need to arrange data of "File 2" with respect to "File 1" and as per following requirement

Step 1:
First In "File 1" need to remove duplicate headers, but contents below these header to be grouped under first one
Refer "File 1" image example : Header "Purge activities" is duplicate at row 10 and 21. Need to remove duplicate row 21 and contents below this header to be moved under row 10(Purge activities) header as shown.

Step 2: Generate separate output file containing data from File 1 and File 2

Next w.r.t to the above updated "File 1" need to re-arrange data of column "C(Activity #) and D(Activity step Name)" from "File 2" as separate out put file as shown below

In both the files data in column "Activity #" is same but not in same order, and "Activity step name" also different in both files.
so Final output file should be as shown below. Also if any Activity # is not available in "File 2" w.r.t "File 1"that row should be empty in the output file.
Please use the same row and column references as shown in the file1 and file 2.

 

[RobP]

Hi,

sorry the code is a little long - it could probably be optimised somewhat - but give this a go and let me know if it doe what you need. There are two subroutines here, one for each file processing. One will call the other automatically.

You need to put this VBA code inside your "output" file. It will ask you to open File1 first, sort and copy that, and then "File2". Both files are then closed leaing you with your output file only.

cheers
Rob

Sub rearrange_File1()

'Store & Run this macro from a clean output file. No need to put any code into your File1 or File2.
'It will first prompt you to open your File1, re-arrange the order as requested, and copy the output columns back to this Output file.
'Then it will prpmpt you to open your File2, and do the same.

'Both file outputs will appear on sheet1 of this output file side by side.


Dim lastrow, purgecnt, fillcnt, resumecnt As Long
Dim wb As Workbook
Dim newwb As Workbook
Dim rn1 As Range
Dim rn2 As Range

Set wb = Application.ActiveWorkbook

With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        Application.Workbooks.Open .SelectedItems(1)
        Set newwb = Application.ActiveWorkbook
             
        lastrow = Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
      
        For x = 11 To lastrow

            If InStr(1, newwb.Sheets("Sheet1").Range("F" & x), "Purge_") Then
                temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 6).End(xlUp).Row
                newwb.Sheets("Sheet1").Range("A" & temprow + 1, "F" & temprow + 1).Value = newwb.Sheets("Sheet1").Range("A" & x, "F" & x).Value
            End If
    
        Next x

        newwb.Sheets("Sheet1").Range("F" & temprow + 2).Value = "Fill Activities"
        newwb.Sheets("Sheet1").Range("A" & temprow + 2, "F" & temprow + 2).Interior.ColorIndex = 44

        For x = 11 To lastrow

            If InStr(1, newwb.Sheets("Sheet1").Range("F" & x), "Fill_") Then
                temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 6).End(xlUp).Row
                newwb.Sheets("Sheet1").Range("A" & temprow + 1, "F" & temprow + 1).Value = newwb.Sheets("Sheet1").Range("A" & x, "F" & x).Value
            End If
    
        Next x

        newwb.Sheets("Sheet1").Range("F" & temprow + 2).Value = "Resume Activities"
        newwb.Sheets("Sheet1").Range("A" & temprow + 2, "F" & temprow + 2).Interior.ColorIndex = 44

        For x = 11 To lastrow

            If InStr(1, newwb.Sheets("Sheet1").Range("F" & x), "Res_") Then
                temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 6).End(xlUp).Row
                newwb.Sheets("Sheet1").Range("A" & temprow + 1, "F" & temprow + 1).Value = newwb.Sheets("Sheet1").Range("A" & x, "F" & x).Value
            End If
    
        Next x

        temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 6).End(xlUp).Row
        newwb.Sheets("Sheet1").Range("A" & lastrow + 1, ("F" & temprow)).Cut Destination:=newwb.Worksheets("Sheet1").Range("A" & 11)

        newwb.Sheets("Sheet1").Range("A" & 11, "F" & lastrow).CurrentRegion.EntireColumn.AutoFit
        
        Set rn1 = newwb.Sheets("Sheet1").Range("D9", "D" & lastrow)
        Set rn2 = newwb.Sheets("Sheet1").Range("F9", "F" & lastrow)
       
        wb.Activate
        
        acnt = lastrow - 9
        rn1.Copy wb.Sheets("Sheet1").Range("A1", "A" & acnt)
        rn2.Copy wb.Sheets("Sheet1").Range("B1", "B" & acnt)
                      
        wb.Sheets("Sheet1").Range("A" & 1, "A" & acnt).CurrentRegion.EntireColumn.AutoFit
        wb.Sheets("Sheet1").Range("B" & 1, "B" & acnt).CurrentRegion.EntireColumn.AutoFit
                        
        newwb.Save
        newwb.Close False
        
    End If
End With

rearrange_file2

End Sub

Sub rearrange_file2()

Dim lastrow, purgecnt, fillcnt, resumecnt As Long
Dim wb As Workbook
Dim newwb As Workbook
Dim rn1 As Range
Dim rn2 As Range

Set wb = Application.ActiveWorkbook

With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        Application.Workbooks.Open .SelectedItems(1)
        Set newwb = Application.ActiveWorkbook
             
        lastrow = Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
      
        For x = 12 To lastrow

            If InStr(1, newwb.Sheets("Sheet1").Range("D" & x), "Purge_") Then
                temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
                newwb.Sheets("Sheet1").Range("A" & temprow + 1, "E" & temprow + 1).Value = newwb.Sheets("Sheet1").Range("A" & x, "E" & x).Value
            End If
    
        Next x

        newwb.Sheets("Sheet1").Range("D" & temprow + 2).Value = "Fill Activities"
        newwb.Sheets("Sheet1").Range("A" & temprow + 2, "E" & temprow + 2).Interior.ColorIndex = 15

        For x = 12 To lastrow

            If InStr(1, newwb.Sheets("Sheet1").Range("D" & x), "Fill_") Then
                temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
                newwb.Sheets("Sheet1").Range("A" & temprow + 1, "E" & temprow + 1).Value = newwb.Sheets("Sheet1").Range("A" & x, "E" & x).Value
            End If
    
        Next x

        newwb.Sheets("Sheet1").Range("D" & temprow + 2).Value = "Resume Activities"
        newwb.Sheets("Sheet1").Range("A" & temprow + 2, "E" & temprow + 2).Interior.ColorIndex = 15

        For x = 12 To lastrow

            If InStr(1, newwb.Sheets("Sheet1").Range("D" & x), "Res_") Then
                temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
                newwb.Sheets("Sheet1").Range("A" & temprow + 1, "E" & temprow + 1).Value = newwb.Sheets("Sheet1").Range("A" & x, "E" & x).Value
            End If
    
        Next x

        temprow = newwb.Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
        newwb.Sheets("Sheet1").Range("A" & lastrow + 1, ("E" & temprow)).Cut Destination:=newwb.Worksheets("Sheet1").Range("A" & 12)

        newwb.Sheets("Sheet1").Range("A" & 12, "E" & lastrow).CurrentRegion.EntireColumn.AutoFit
        
        Set rn1 = newwb.Sheets("Sheet1").Range("C10", "C" & lastrow)
        Set rn2 = newwb.Sheets("Sheet1").Range("D10", "D" & lastrow)
       
        wb.Activate
        
        acnt = lastrow - 9
        rn1.Copy wb.Sheets("Sheet1").Range("D1", "D" & acnt)
        rn2.Copy wb.Sheets("Sheet1").Range("E1", "E" & acnt)
                      
        wb.Sheets("Sheet1").Range("D" & 1, "D" & acnt).CurrentRegion.EntireColumn.AutoFit
        wb.Sheets("Sheet1").Range("E" & 1, "E" & acnt).CurrentRegion.EntireColumn.AutoFit
                        
        newwb.Save
        newwb.Close False
        
    End If
End With


End Sub

 

[Zot]

Will you have duplicated Activity Name in File1? If not, then try the code below. I separated into 3 parts. Just run the Test. You put code in File1. Once run, it will ask for File2 and the Result workbook will be created automatically.

Sub Test()

Dim n As Long
Dim x As Variant, ArryCriteria() As Variant
Dim rngCol As Range
Dim ws1 As Worksheet
Dim wb1 As Workbook

Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")

Application.ScreenUpdating = False

ArryCriteria = Array("Purge Activities", "Fill Activities", "Resume Activities")
For Each x In ArryCriteria
    ws1.Range("F7").AutoFilter Field:=6, Criteria1:=x
    n = ws1.Range("F7", ws1.Range("F7").End(xlDown)).SpecialCells(xlCellTypeVisible).Count
    If n > 2 Then
        ws1.Range("F7").AutoFilter
        Call MoveDupe(ws1, x)
    End If
Next
If ws1.AutoFilterMode = True Then ws1.Range("F7").AutoFilter
ws1.Range("A7", ws1.Cells(Rows.Count, "F").End(xlUp)).RemoveDuplicates Columns:=6
Call CompareWB(x)
Application.ScreenUpdating = True

End Sub

Sub MoveDupe(ws As Worksheet, Crit As Variant)

Dim n As Long
Dim strAdd As String
Dim key As Variant
Dim cell As Range, c As Range, rngData As Range
Dim dictData As Object

Set dictData = CreateObject("Scripting.Dictionary")
Set rngData = ws.Range("F8", ws.Cells(Rows.Count, "F").End(xlUp))

n = 0
For Each cell In rngData
    If cell = Crit Then
        For Each c In ws.Range("D" & cell.Row + 1, ws.Cells(Rows.Count, "D").End(xlUp).Offset(1))
            If Len(c) = 0 Then
                strAdd = ws.Range("A" & cell.Row + 1, "F" & c.Row - 1).Address
                Exit For
            End If
        Next
        n = n + 1
        dictData.Add n, strAdd
    End If
Next

Set rngData = Nothing
For Each key In dictData
    If Not key = 1 Then
        If rngData Is Nothing Then
            Set rngData = ws.Range(dictData(key))
        Else
            Set rngData = Union(rngData, ws.Range(dictData(key)))
        End If
    End If
Next
rngData.Cut
ws.Rows(Split(Split(dictData(1), ":")(1), "$")(2) + 1).Insert shift:=xlDown


End Sub

Sub CompareWB(x As Variant)

Dim OriShtCount As Long
Dim NewName As String, strAdd As String
Dim cell As Range, c As Range, rngFound As Range
Dim rngActivity As Range, rngData As Range, rngCopy As Range
Dim Fname As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, wsResult As Worksheet
Dim wb1 As Workbook, wb2 As Workbook, wbResult As Workbook

Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Sheet1")

'Open workbook to compare (File2)
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm; *.xlsb), *.xls; *.xlsx; *.xlsm; *.xlsb", Title:="Select a File")
If Fname = False Then Exit Sub                         'CANCEL is clicked
Set wb2 = Workbooks.Open(Filename:=Fname, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
Set ws2 = wb2.Sheets("Sheet1")               'Assuming sheet name is Sheet1. Rename as required.

'Create new workbook with one sheet Result
OriShtCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wbResult = Workbooks.Add
wbResult.SaveAs Filename:=wb1.Path & "\" & "Result"
Set wsResult = wbResult.Sheets("Sheet1")
Application.SheetsInNewWorkbook = OriShtCount

wsResult.Range("A1") = "Activity #"
wsResult.Range("B1") = "Activity Name"
wsResult.Range("D1") = "Activity #"
wsResult.Range("E1") = "Activity Step Name"

Set rngCopy = Union(ws1.Range("D8", ws1.Cells(Rows.Count, "D").End(xlUp)), ws1.Range("F8", ws1.Cells(Rows.Count, "F").End(xlUp)))
rngCopy.Copy wsResult.Range("A2")

Set rngData = ws2.Range("D11", ws2.Cells(Rows.Count, "D").End(xlUp))

For Each cell In wsResult.Range("B2", wsResult.Cells(Rows.Count, "B").End(xlUp))
    Select Case cell
        Case "Purge Activities", "Fill Activities", "Resume Activities"
            Set rngFound = rngData.Find(cell)
            If Not rngFound Is Nothing Then
                For Each c In ws2.Range("C" & rngFound.Row + 1, ws2.Cells(Rows.Count, "C").End(xlUp).Offset(1))
                    If Len(c) = 0 Then
                        strAdd = ws2.Range("C" & rngFound.Row + 1, "C" & c.Row - 1).Address
                        Exit For
                    End If
                Next
                Set rngActivity = ws2.Range(strAdd)
            End If
    End Select
    If cell.Offset(0, -1) = "" Then
        ws2.Range("D" & rngFound.Row).Copy wsResult.Range("E" & cell.Row)
    Else
        Set rngFound = rngActivity.Find(cell.Offset(0, -1))
        If Not rngFound Is Nothing Then
            Debug.Print rngFound.Address
            ws2.Range("C" & rngFound.Row, "D" & rngFound.Row).Copy wsResult.Range("D" & cell.Row)
        End If
    End If
Next
wsResult.Cells.EntireColumn.AutoFit

End Sub