Copy from one source file into multiple excel files - All live in one location

[babar2019]

Hello ,

I have an excel file which is the source document and I have other excel files which are destination files all in one location.

- I want VBA to open the source excel and Format the Date in Column C of the source to MM YYYY.
- Check if column A has the word 'SIGNAPAY' ,
- If true then open a document called 'In process SIGNAPAY.xlsx' from that location,
- Click on the sheet name which matches with Column C (MM YYYY) of the source excel.
- Copy rows through columns A:G in the source excel for all rows which have SIGNAPAY in column A and paste into the last empty rows in the 'In Process SIGNAPAY.xlsx' workbook.

Below is what the data would look like:

DMTITL	DHACCT	DHDATE	DHDATC	DHITC	DHAMT	DESC1	DESC2
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019189	70819	55	259	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019189	70819	55	499	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019189	70819	55	2795.81	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019189	70819	55	6000	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019189	70819	55	6500	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019190	70919	55	114	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019191	71019	18	834.47	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019191	71019	18	1590.7	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019191	71019	18	2609.02	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019191	71019	18	3294.32	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019191	71019	18	4632.49	Testing	Test Company
SIGNAPAY LTD IN PROCESS ACCOUN	xxxxxxxxxx	2019191	71019	18	6667.57	Testing	Test Company

<tbody>
</tbody>

 

[mumps]

Thank you for the files. I'll start to have a closer look at the files and get back to you as soon as I can. Would it be a problem if we inserted a column in the source file that would contain the "File to open" for each cell in column A?

 

[babar2019]

Thank you very much for the response. Really appreciate it.

As long as the macro deletes the column at the end of the code I think should be fine. Because our users would like the source file to leave it the way it is.

 

[mumps]

Column D in the Source file is formatted as "General" whereas column B in the destination file is formatted as "mm/dd/yy". Would 70819 represent "07/08/19" formatted as "mm/dd/yy"? Also, in the destination file, you have formulas in columns G, H and I and in the bottom 3 rows of each sheet. Do you want the macro to create these formulas as data is copied over? Would a blank destination sheet before any data is pasted look like this:
Excel 2010 32 bit

	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​
1​	DDA:		2CP In Process DDA
2​	Account #:		123456789		​
3​	Account Name:		In Process DDA Account
4​	Date:		07/31/19	Interim	​
5​	Prepared By:
6​	Approved By:				​
7​
8​		Date	Description​	​	DR/CR​	Amount​	Debit​	Credit​	Balance​		​
9​			​	​	​	​	​	​	​
10​					​		​	​
11​					​		​	​	-​
12​					​		​	​	-​
13​		07/31/19	Reconcilation Totals		​	- ​	- ​	- ​	- ​
14​		07/31/19	General Ledger Balance		​	-​					Input total
15​		07/31/19	Difference		​	-​			- ​

Sheet: 0719

 

[babar2019]

Hello.. That's correct. The source file is formatted as m/dd/yy but destination column B is mm/dd/yy.

You can ignore the rows which have the formulas that you see on every sheet. They are user entered. I will have them delete it manually later on. Please see if you can just paste right above the 'Reconciliation totals' row for every sheet.

Thank you very much in advance.

 

[mumps]

Place this macro in the Source workbook. Save the workbook as a macro-enabled file into the same folder as the destination files. The macro assumes that a destination file exists for each account in column A of the Source workbook. If any destination file is missing, the macro will generate an error.

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, 1).EntireRow.Resize(RowCount - 1).Insert Shift:=xlDown
                            srcWS.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1 - 1, 2)
                            totals2 = desWS.Range("C:C").Find("Reconcilation Totals").Row
                            For Each rng In desWS.Range("B" & totals1 - 1 & ":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 - 1, 5)
                                .Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1 - 1, 6)
                                .Range("G2:G" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1 - 1, 3)
                                .Range("H2:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(totals1 - 1, 4)
                            End With
                        End With
                        srcWS.Cells(1).AutoFilter
                    Next key2
                    totals2 = desWS.Range("C:C").Find("Reconcilation Totals").Row
                    With desWS
                        For Each code In Array("55", "78")
                            .Range("E12:E" & totals2 - 1).Replace code, "Debit"
                        Next code
                        For Each code In Array("18", "38")
                            .Range("E12:E" & totals2 - 1).Replace code, "Credit"
                        Next code
                    End With
                End With
            End If
        Next i
        RngList2.RemoveAll
        wkbDest.Close True
    Next key1
    Application.ScreenUpdating = True
End Sub

 

[babar2019]

Hello,

I just tried to run the macro from the source file for just the 'In Process DDA Recon - Signapay' as detination file. It run into an error saying 'No cells found'. When I hit debug, it takes me to the code line below:

For Each rng2 In srcWS.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible)

In my source file, I just have like 19 rows altogether. I just wanted to test for 1 file and test all at once.

Thank you very much..

 

[mumps]

Do you have values in column D in the Source file for each account in column A? I tested the macro on the two files you uploaded and it worked properly. Are you using the macro on the same two files or on different files? If on different files, please upload the two files that are generating the error.

 

[babar2019]

Good morning,

Thank you for looking into this. Please see below file links uploaded to Box:

Source: https://esquirebank.box.com/s/xlwed7pk5vf0ce57yndwvg1s6jj64cmt
Destination: https://esquirebank.box.com/s/nq1xd85v0rzugr7qxk7rm9o6cjph3omk

What I'm doing is opening the source file, go to view-Macros-Create New - Copy paste your macro and running it.

It errors out saying no cells found.

Thank you

 

[mumps]

Try:

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
                        For Each code In Array("55", "78")
                            .Range("E12:E" & totals2 - 1).Replace code, "Debit"
                        Next code
                        For Each code In Array("18", "38")
                            .Range("E12:E" & totals2 - 1).Replace code, "Credit"
                        Next code
                    End With
                End With
            End If
        Next i
        RngList2.RemoveAll
        wkbDest.Close True
    Next key1
    Application.ScreenUpdating = True
End Sub

 

[babar2019]

Hi.. Still the same error message.

Is it working for you? If it is, I'm not sure what I'm doing wrong. It's the same exact files that I have sent you over.