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