Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook, srcWS As Worksheet, desWS As Worksheet, LastRow As Long, key1 As Variant, key2 As Variant, totals1 As Long, totals2 As Long
Dim RngList1 As Object, RngList2 As Object, rng As Range, rng1 As Range, rng2 As Range, arr As Variant, i As Long, fNames As String, code As Variant
Set srcWS = ThisWorkbook.Sheets("QRYLIBA380.CSIPHIST>Sheet1")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
fNames = "SIGNAPAY LTD IN PROCESS ACCOUN,In Process DDA Recon - SignaPay,EPT 6001 IN PROCESS ACCOUNT,In Process DDA Recon - EPS,APS IN PROCESS ACCOUNT," & _
"In Process DDA Recon - APS,PAYMENT WORLD IN PROCESS ACCT,In Process DDA Recon - Payment World,TRISOURCE IN PROCESS ACCOUNT," & _
"In Process DDA Recon - TriSource,BANCTEK SOLUTIONS IN PROCESS,In Process DDA Recon - BancTek,MERCHANT BANCARD IN PROCESS,In Process DDA Recon - MBN," & _
"ADVANCE MERCHANT IN PROCESS AC,In Process DDA Recon - DAS,2C PROCESSOR IN PROCESS,In Process DDA Recon - 2CP,FRONTLINE IN PROCESS ACCOUNT," & _
"In Process DDA Recon - FrontLine,TITANIUM PROCESSING IN PROCESS,In Process DDA Recon - Titanium Processing,ARGUS MERCHANT IN PROCESS ACCT," & _
"In Process DDA Recon - Argus,INFINITY CAPTIAL LLC IN PROCES,In Process DDA Recon - Choice,TITANIUM PAYMENTS IN PROCESS," & _
"In Process DDA Recon - Titanium Payments,MERCHANT INDUSTR IN PROCESS,In Process DDA Recon - Merchant Industry,UNIFIED PAYMENTS IN PROCESS," & _
"In Process DDA Recon - Unified,ELECTRONIC MERCHANT SYS IN PRO,In Process DDA Recon - EMS Conversion,MAVERICK IN PROCESS ACCOUNT," & _
"In Process DDA Recon - Maverick,PIVOTAL PAYMENTS IN PROCESS,In Process DDA Recon - Nuvei,C&H FINANCIAL SERVICES IN PROC In Process DDA Recon - C&H," & _
"MERCHANT LYNX SERVICES IN PROC,In Process DDA Recon - Merchant Lynx"
arr = Split(Application.Trim(fNames), ",")
Set RngList1 = CreateObject("Scripting.Dictionary")
Set RngList2 = CreateObject("Scripting.Dictionary")
For Each rng1 In srcWS.Range("A2", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp))
If Not RngList1.Exists(rng1.Value) Then
RngList1.Add rng1.Value, Nothing
End If
Next rng1
For Each key1 In RngList1
For i = 0 To UBound(arr)
If arr(i) = key1 Then
Set wkbDest = Workbooks.Open(ThisWorkbook.Path & "\" & arr(i + 1) & ".xlsx")
With srcWS.Cells(1).CurrentRegion
.AutoFilter 1, key1
For Each rng2 In srcWS.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible)
If Not RngList2.Exists(rng2.Value) Then
RngList2.Add rng2.Value, Nothing
End If
Next rng2
For Each key2 In RngList2
Set desWS = ActiveWorkbook.Sheets(Format(DateSerial(Right(key2, 2), Left(key2, Len(key2) - 4), Mid(key2, Len(key2) - 3, 2)), "mmyy"))
With srcWS.Cells(1).CurrentRegion
.AutoFilter 4, key2
totals1 = desWS.Range("C:C").Find("Reconcilation Totals").Row
RowCount = srcWS.[subtotal(103,A:A)] - 1
desWS.Cells(totals1, 1).EntireRow.Resize(RowCount).Insert Shift:=xlDown
srcWS.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 2)
totals2 = desWS.Range("C:C").Find("Reconcilation Totals").Row
For Each rng In desWS.Range("B" & totals1 & ":B" & totals2 - 1)
rng = Format(DateSerial(Right(rng, 2), Left(rng, Len(rng) - 4), Mid(rng, Len(rng) - 3, 2)), "mm/dd/yy")
Next rng
With srcWS
.Range("E2:E" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 5)
.Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 6)
.Range("G2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 3)
.Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1, 4)
End With
End With
srcWS.Cells(1).AutoFilter
Next key2
totals2 = desWS.Range("C:C").Find("Reconcilation Totals").Row
With desWS.Range("B12:B" & totals2 - 1)
.Font.Name = "Bookman Old Style"
.Font.Color = 10040115
.Font.Size = 10
.HorizontalAlignment = xlLeft
End With
With desWS.Range("C12:C" & totals2 - 1)
.Font.Name = "Bookman Old Style"
.Font.Size = 10
.HorizontalAlignment = xlLeft
End With
With desWS.Range("D12:D" & totals2 - 1)
.Font.Name = "Bookman Old Style"
.Font.Color = 10040115
.Font.Size = 10
.HorizontalAlignment = xlLeft
End With
With desWS.Range("E12:E" & totals2 - 1)
.Font.Name = "Bookman Old Style"
.Font.Color = 10040115
.Font.Size = 10
.HorizontalAlignment = xlCenter
End With
With desWS.Range("F12:F" & totals2 - 1)
.Font.Name = "Bookman Old Style"
.Font.Color = 10040115
.Font.Size = 10
End With
With desWS
For Each code In .Range("E12:E" & totals2 - 1)
If code = "55" Or code = "78" Then
If code.Offset(, 1) > 0 Then
code.Offset(, 1) = "-" & code.Offset(, 1)
End If
code.Offset(, 1).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
ElseIf code = "18" Or code = "38" Then
code.Offset(, 1).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
End If
Next code
End With
With desWS
.Range("G12:I12").Copy
.Range("G13:I" & totals2 - 1).PasteSpecial Paste:=xlPasteFormulas
End With
End With
End If
Next i
RngList2.RemoveAll
'wkbDest.Close True
Next key1
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
