Public Sub workbook_fail()
Application.ScreenUpdating = False
Dim RngToCopy As Range
Dim DestCell As Range
joker = 0
lower = 0
upper = 0
ntimes = 1
initarray = 0
i = 0
j = 0
m = 0
n = 0
r = 2
'=====================================================================
' loop to take the last row counter of the data
'=====================================================================
'clear sheet contents and formats
Sheets("sheet3").Select
Columns("A:F").Select
Selection.Delete Shift:=xlToLeft
Sheets("sheet2").Select
Cells.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Sheets("sheet1").Select
For n = 1 To 1000000
If Cells(n, 1).Value = "" Then
n = n + 3
If Cells(n, 1).Value = "" Then
n = n + 4
If Cells(n, 1).Value = "" Then
n = n - 7
Exit For
End If
End If
End If
Next
'=====================================================================
' block to check the two consective empty cells after each Payer and "Total"
'=====================================================================
For joker = ntimes To n
If Cells(joker, 1).Value = "Payer" Then
Cells(joker, 1).Select
lower = joker
Else
If Cells(joker, 1).Value = "Total:" Then
Cells(joker, 1).Select
joker = joker + 1
If Cells(joker, 1).Value = "" Then
joker = joker + 1
If Cells(joker, 1).Value = "" Then
upper = joker - 2
ntimes = joker + 1
'=====================================================================
' inner block which check failed value condition
'=====================================================================
copl = lower
copu = upper
For q = lower To upper
For m = 1 To 5
If Cells(q, m).Value = "Failed" Then
Sheets("sheet1").Range(Cells(copl, 1), Cells(copu, 5)).Select
Selection.Copy
Sheets("sheet2").Select
Range(Cells(copl, 1), Cells(copu, 5)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range(Cells(copl, 1), Cells(copu, 5)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
For p = r To 100000
Sheets("sheet1").Select
Range(Cells(lower + 1, 1), Cells(lower + 1, 5)).Select
Selection.Copy
Sheets("sheet3").Select
Range(Cells(p, 1), Cells(p, 5)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Range(Cells(p, 1), Cells(p, 5)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("sheet3").Select
Range(Cells(p, 1), Cells(p, 5)).Select
Sheets("Sheet1").Select
Cells(q, m).Offset(0, -1).Select
Selection.Copy
Sheets("Sheet3").Select
Cells(p, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(p, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(p, 6).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
r = r + 1
Exit For
Next
Exit For
End If
Next
Next
'=====================================================================
' END inner block which check failed value condition, Block paste values if failed condition satisfied
'=====================================================================
End If
End If
End If
End If
Sheets("sheet1").Select
Next joker
Sheets("sheet3").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
ActiveWindow.SmallScroll Down:=0
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.NumberFormat = "m/d/yyyy"
Range("A1").Select
ActiveCell.FormulaR1C1 = "Compnay Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Date "
Range("C1").Select
ActiveCell.FormulaR1C1 = "company information"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Payment($)"
Columns("A:D").Select
Selection.ColumnWidth = 27.43
Application.ScreenUpdating = True
End Sub
Bookmarks