Pasting to a Row with a Specific Value in another Workbook

M

Maccers93

New Member
Joined
Feb 12, 2021
Messages
29
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I am quite new to this and I have gotten so far but I can't seem to find a structure to do what I need to do.

Below I have attached Workbook1 and Workbook2. I can move data from both workbooks, but I was to paste to a row/column that has a specific value in Workbook2.

In my code, I can find the rows containing 301 and 302, and then copy them. I do not want to assign a column/row when pasting to the Workbook2. Is there anyway I could read Workbook2, find "Account 301" in column A, skip the subheadings (row below), and search for "- AE" in column E, then paste all additional rows copied from 301 from Workbook1 to this row?

Workbook1.xlsm
ABCDEFGH
1Account: 301
2
3DateDetailsReferenceTypeDebitCreditBalance
4
521/01/2019PURCHASE301Bank665.00-665.00
619/03/2019PURCHASE301Bank120.00-785.00
701/04/2019PURCHASE301Bank384.00-1,169.00
803/05/2019PURCHASE301Bank500.00-1,669.00
910/05/2019PURCHASE301Bank500.00-2,169.00
1010/05/2019PURCHASE301Bank500.00-2,669.00
1117/05/2019PURCHASE301Bank500.00-3,169.00
1223/05/2019PURCHASE301Bank500.00-3,669.00
1329/05/2019PURCHASE301Bank585.00-4,254.00
14
15Account: 302
16
17DateDetailsReferenceTypeDebitCreditBalance
18
1921/01/2019PURCHASE302Bank1,000.00-1,000.00
2018/02/2019PURCHASE302Bank500.00-1,500.00
2101/03/2019PURCHASE302Bank1,000.00-2,500.00
2213/03/2019PURCHASE302Bank1,000.00-3,500.00
2318/04/2019PURCHASE302Bank1,000.00-4,500.00
2431/05/2019PURCHASE302Bank1,000.00-5,500.00
2519/06/2019PURCHASE302Bank1,000.00-6,500.00
2602/07/2019PURCHASE302Bank1,000.00-7,500.00
2726/07/2019PURCHASE302Bank1,000.00-8,500.00
2806/08/2019PURCHASE302Bank1,000.00-9,500.00
Sheet6


Workbook2.xlsx
ABCDEFGH
1Account 301
2Tran No.Bat No.DateRef No.NarrativeDebitCreditBalance
374433131/12/2019ECWages - AE21439.000.0021439.00
477233631/12/2019ECNarrative6580.960.0028019.96
577533731/12/2019ECNarrative19.640.0028039.60
628039.600.0028039.60
7
8Account 302
9Tran No.Bat No.DateRef No.NarrativeDebitCreditBalance
1074533131/12/2019ECD.R- AE16500.000.0016500.00
1177333631/12/2019ECNarrative9953.520.0026453.52
Sheet2


VBA Code: 
Sub Test()

Dim x As Workbook 'Determining Workbook
Dim y As Workbook 'Determining Workbook

Set x = Workbooks.Open("Workbook1.xlsm") 'Opens Workbook1
Set y = Workbooks.Open("Workbook2.xlsx") 'Opens Workbook2

Dim rw As Long, Cell As Range

        For Each Cell In x.Sheets("Sheet5").Range("D2:D1000") 'Range of read first workbook
            rw = Cell.Row
            If Cell.Value = "301" Then 'Search for 301
                Cell.EntireRow.Copy 'Copies entire row containing 302
                y.Sheets("Sheet2").Range("A1").Insert xlShiftDown 'Pastes to Workbook2 on a designated line and creates more below it
            End If
            If Cell.Value = "302" Then 'Search for 302
                Cell.EntireRow.Copy 'Copies entire row containing 302
                y.Sheets("Sheet2").Range("A50").Insert xlShiftDown 'Pastes to Workbook2 on a designated line and creates more below it
            End If
        Next
End Sub

Thanks in advance!
 
Sort by date Sort by votes
It looks to me the code was working exactly like the result you've wanted except the Account Number has text after the number which was not in your previous sample. I just check 3 accounts.

To solve this, I use VB Script Regular Expression (RegEx) to search for pattern Account: 3 or Account: 300. Note that you must add reference to RegEx. In VB Editor:
Go to Reference > Tools > References to the "Microsoft VBScript Regular Expressions 5.5" Object Library

Here is modified code. Let me know if you found something not correct

VBA Code: 
Sub Test()

Dim wbX As Workbook 'Determining Workbook
Dim wbY As Workbook 'Determining Workbook
Dim ws1 As Worksheet 'Determining Worksheet
Dim ws2 As Worksheet 'Determining Worksheet
Dim rngFound As Range 'Determining Range
Dim rngSearch As Range 'Determining Range
Dim Fname As Variant
Dim DictAcc As Object, RegEx As Object

' Select file
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm; *.xlsb; *.xml), *.xls; *.xlsx; *.xlsm; *.xlsb; *.xml", _
                                                            Title:="Select a File")
If Fname = False Then                          'CANCEL is clicked
    Exit Sub
End If

Set wbX = Workbooks.Open(Filename:=Fname, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
Set ws1 = wbX.Sheets("Sheet5") ' Worksheet

Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm; *.xlsb; *.xml), *.xls; *.xlsx; *.xlsm; *.xlsb; *.xml", _
                                                            Title:="Select a File")
If Fname = False Then                          'CANCEL is clicked
    Exit Sub
End If

Set wbY = Workbooks.Open(Filename:=Fname, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
Set ws2 = wbY.Sheets("Sheet1") 'Worksheet

Set DictAcc = CreateObject("Scripting.Dictionary")
Set RegEx = CreateObject("VBScript.RegExp")

Application.ScreenUpdating = False

With RegEx
    .Pattern = "Account:\s\d{1,3}"
    .IgnoreCase = IgnoreCase
End With

Dim strAcc As String
Dim Result As Variant
Dim Cell As Range

' Use Regular Expression to search for all Acc #.
' Must add reference (Tools > References) to the
' "Microsoft VBScript Regular Expressions 5.5" Object Library
' Store info in DictAcc as row# (key) and Acc # (value)
For Each Cell In ws1.Range("C1:C1000")
    If RegEx.Test(Cell) Then
        Set Result = RegEx.Execute(Cell)
        With Result(0)
            strAcc = Right(.Value, Len(.Value) - 9)
            strAcc = Replace(.Value, strAcc, Format(strAcc, "000"))
            strAcc = Replace(strAcc, ":", "")
        End With
        DictAcc.Add Cell.Row, strAcc
    End If
Next

Dim iRow As Long, eRow As Long
Dim key As Variant

' Loop through each Account number in Dictionary
For Each key In DictAcc
    strAcc = DictAcc(key)
    Set rngFound = ws2.Range("A1", ws2.Cells(ws2.Rows.Count, "A").End(xlUp)).Find(strAcc)  ' Find matching account number
    Set rngSearch = ws2.Range("E" & rngFound.Row, ws2.Cells(ws2.Rows.Count, "E").End(xlDown)).Find("- AE", LookAt:=xlPart) 'Search for "- AE"
    If Not rngFound Is Nothing Then
        If Not Len(ws1.Range("C" & key + 5)) = 0 Then                                                         ' Check if specific account has more than one line to copy
            ws1.Range("C" & key + 4, "C" & ws1.Range("C" & key + 4).End(xlDown).Row).EntireRow.Copy
        Else
            ws1.Range("C" & key + 4).EntireRow.Copy
        End If
        If Not rngSearch Is Nothing Then
            iRow = rngSearch.Row
            With ws2.Range("A" & rngSearch.Row).EntireRow
                .Insert
                .Delete                                                                                                        ' Delete row "- AE"
            End With
        Else
            iRow = rngFound.Row + 2
            ws2.Range("A" & rngSearch.Row).EntireRow.Insert
        End If
        
        With ws2
            eRow = .Range("F" & iRow).End(xlDown).Row - 1
            With .Range("F" & iRow, "H" & eRow + 1)
                .NumberFormat = "#,##0.00"
                .HorizontalAlignment = xlGeneral
            End With
            .Range("F" & eRow + 1).Formula = "=SUM(F" & iRow & ":F" & eRow & ")"
            .Range("G" & eRow + 1).Formula = "=SUM(G" & iRow & ":G" & eRow & ")"
            .Range("H" & eRow + 1).Formula = "=SUM(H" & iRow & ":H" & eRow & ")"
        End With
    End If
Next

End Sub
 
Upvote 0
Solution

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Zot said:
It looks to me the code was working exactly like the result you've wanted except the Account Number has text after the number which was not in your previous sample. I just check 3 accounts.

To solve this, I use VB Script Regular Expression (RegEx) to search for pattern Account: 3 or Account: 300. Note that you must add reference to RegEx. In VB Editor:
Go to Reference > Tools > References to the "Microsoft VBScript Regular Expressions 5.5" Object Library

Here is modified code. Let me know if you found something not correct

VBA Code: 
Sub Test()

Dim wbX As Workbook 'Determining Workbook
Dim wbY As Workbook 'Determining Workbook
Dim ws1 As Worksheet 'Determining Worksheet
Dim ws2 As Worksheet 'Determining Worksheet
Dim rngFound As Range 'Determining Range
Dim rngSearch As Range 'Determining Range
Dim Fname As Variant
Dim DictAcc As Object, RegEx As Object

' Select file
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm; *.xlsb; *.xml), *.xls; *.xlsx; *.xlsm; *.xlsb; *.xml", _
                                                            Title:="Select a File")
If Fname = False Then                          'CANCEL is clicked
    Exit Sub
End If

Set wbX = Workbooks.Open(Filename:=Fname, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
Set ws1 = wbX.Sheets("Sheet5") ' Worksheet

Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm; *.xlsb; *.xml), *.xls; *.xlsx; *.xlsm; *.xlsb; *.xml", _
                                                            Title:="Select a File")
If Fname = False Then                          'CANCEL is clicked
    Exit Sub
End If

Set wbY = Workbooks.Open(Filename:=Fname, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
Set ws2 = wbY.Sheets("Sheet1") 'Worksheet

Set DictAcc = CreateObject("Scripting.Dictionary")
Set RegEx = CreateObject("VBScript.RegExp")

Application.ScreenUpdating = False

With RegEx
    .Pattern = "Account:\s\d{1,3}"
    .IgnoreCase = IgnoreCase
End With

Dim strAcc As String
Dim Result As Variant
Dim Cell As Range

' Use Regular Expression to search for all Acc #.
' Must add reference (Tools > References) to the
' "Microsoft VBScript Regular Expressions 5.5" Object Library
' Store info in DictAcc as row# (key) and Acc # (value)
For Each Cell In ws1.Range("C1:C1000")
    If RegEx.Test(Cell) Then
        Set Result = RegEx.Execute(Cell)
        With Result(0)
            strAcc = Right(.Value, Len(.Value) - 9)
            strAcc = Replace(.Value, strAcc, Format(strAcc, "000"))
            strAcc = Replace(strAcc, ":", "")
        End With
        DictAcc.Add Cell.Row, strAcc
    End If
Next

Dim iRow As Long, eRow As Long
Dim key As Variant

' Loop through each Account number in Dictionary
For Each key In DictAcc
    strAcc = DictAcc(key)
    Set rngFound = ws2.Range("A1", ws2.Cells(ws2.Rows.Count, "A").End(xlUp)).Find(strAcc)  ' Find matching account number
    Set rngSearch = ws2.Range("E" & rngFound.Row, ws2.Cells(ws2.Rows.Count, "E").End(xlDown)).Find("- AE", LookAt:=xlPart) 'Search for "- AE"
    If Not rngFound Is Nothing Then
        If Not Len(ws1.Range("C" & key + 5)) = 0 Then                                                         ' Check if specific account has more than one line to copy
            ws1.Range("C" & key + 4, "C" & ws1.Range("C" & key + 4).End(xlDown).Row).EntireRow.Copy
        Else
            ws1.Range("C" & key + 4).EntireRow.Copy
        End If
        If Not rngSearch Is Nothing Then
            iRow = rngSearch.Row
            With ws2.Range("A" & rngSearch.Row).EntireRow
                .Insert
                .Delete                                                                                                        ' Delete row "- AE"
            End With
        Else
            iRow = rngFound.Row + 2
            ws2.Range("A" & rngSearch.Row).EntireRow.Insert
        End If
       
        With ws2
            eRow = .Range("F" & iRow).End(xlDown).Row - 1
            With .Range("F" & iRow, "H" & eRow + 1)
                .NumberFormat = "#,##0.00"
                .HorizontalAlignment = xlGeneral
            End With
            .Range("F" & eRow + 1).Formula = "=SUM(F" & iRow & ":F" & eRow & ")"
            .Range("G" & eRow + 1).Formula = "=SUM(G" & iRow & ":G" & eRow & ")"
            .Range("H" & eRow + 1).Formula = "=SUM(H" & iRow & ":H" & eRow & ")"
        End With
    End If
Next

End Sub
Click to expand...
@Zot you absolute genius, thank you so much for this, I can't thank you enough! Works like a charm! I will credit you in the code, I am genuinely so appreciative of this!

I do have one query, can an application be created to run this code to be more user friendly? Just curious. As in, an application on the desktop for a user to click, select the two workbooks and run the code? Or am I asking too much?

Thank you again!
 
Upvote 0
Maccers93 said:
@Zot you absolute genius, thank you so much for this, I can't thank you enough! Works like a charm! I will credit you in the code, I am genuinely so appreciative of this!

I do have one query, can an application be created to run this code to be more user friendly? Just curious. As in, an application on the desktop for a user to click, select the two workbooks and run the code? Or am I asking too much?

Thank you again!
Click to expand...
VBA is just an interpreted language. It cannot be compiled to make it like an apps. Since I created the macro on just blank Workbook, why not you just create a button that when clicked it would run the code. So, users can just open the Workbook and click button to run it. It will ask for the two files.

The workbook is independent. Just running code.
 
Upvote 0
Zot said:
VBA is just an interpreted language. It cannot be compiled to make it like an apps. Since I created the macro on just blank Workbook, why not you just create a button that when clicked it would run the code. So, users can just open the Workbook and click button to run it. It will ask for the two files.

The workbook is independent. Just running code.
Click to expand...
Can this be loaded by a user as such? Or would I need to attach the button?

just curious how the excel and vba work really, its all a little new to me.
 
Upvote 0
Maccers93 said:
Can this be loaded by a user as such? Or would I need to attach the button?

just curious how the excel and vba work really, its all a little new to me.
Click to expand...
I think I'm not qualified to answer since I have no formal learning on programming. I just start writing VBA when I started working. You just have many routine that you do repeatedly and wanted to automate it and make sure no careless mistake ?

You started this thread with a code, so I think you are more or less familiar with VBA. As far as I know VBA is just an old VB language customized to work seamlessly with application (Excel in this case) which you cannot do easily with pure VB (I believe).

I'm sure when you run my code, the code is in a blank Workbook, right?. You can run the macro using Alt+F8, but to make it user friendly you can create an button in empty Sheet1.

Go to Insert>Shapes and choose whichever shape you like.
Right Click on the shape and choose Assign Macro. A box will pop up and you can choose the subroutine you want to execute.

This way user just open Workbook and click the button you've created to run the macro.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Macro to open multiple workbooks and copy a range of data based on todays date. Then paste the data in master workbook in one sheet under each other.
Replies
8
Views
613
Luke1690
L
T
  • Solved
Copy and Past the Data from Multiple Closed Workbooks
2
Replies
16
Views
1K
thespardian
T
L
  • Solved
Importing specific cell data from one workbook to another
Replies
1
Views
701
rlv01
R
L
  • Question Question
Copy Subtotals from Source Workbook to Current Workbook
Replies
1
Views
409
DanteAmor
DanteAmor
C
  • Solved
Copy paste columns based on matching header into another workbook
Replies
5
Views
218
mumps
mumps

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top