Help with copying info from one excel to another in one action (Attachments)

[brolsen]

Hello and Happy New Year Excel Geniuses!

I have constructed a code that I gathered from some other work I have performed and I am really close to having it do what I want.

Attached are two files (FileToOpen & FileWithVBA).
On FileToOpen there are two tabs with data "Before" and "After"
On FileWithVBA there are the same tabs, but there is no data save for the headers of the columns.

There is a button on FileWithVBA that when clicked, asks the user to open a file. If you select FileToOpen it will run code and then it will ask you again to open a file (click FileToOpen again) and when this is completed, the information from FileToOpen will be transported to FileWithVBA.

What I am trying to accomplish is I want FileWithVBA to complete BOTH codes with only clicking the file one time. I have tried a variety of codes and keep getting errors about already compiling or naming components.
If you save the two files and run the code, you will see what I mean by clicking the FileToOpen more than once.

Couple things:
1.) Can't create code with "FileToOpen" in the code because the name of the file for this code will be different for each person, hence why I need to have the user select a file.
2.) Can't transport the sheet because I need the information copy and pasted, not moved.

if someone can figure out how to make both run without selecting the file twice, I would be super appreciative! Thanks for looking!
Thank you!!!

[davesexcel]

I see what you mean, but don't know what all that code is supposed to do.

[brolsen]

If you open FileWithVBA you will see that the Before and After tabs are blank.

When you click the button it runs two macros. The first macro takes the data from the file selected (FileToOpen) and copies and pastes the data from sheet to sheet (Before-FileToOpen to Before-FilWithVBA). The second code does the same but for the After tab (After-FileToOpen to After-FileWithVBA). However, the code now requires the user to select the file more than once. If you notice, after you select the button and click FileToOpen twice, the Before and After tabs on FileWithVBA are no longer blank.

I am trying to figure out how to do this without clicking FileToOpen more than once. The file I am using this code I need to do this for 20+ sheets and would like to be able to figure out how to do this without clicking the file 20+ times.

Does this answer your question?

[cory0789]

Why dont you just combine them in one sub??? Like I did below... I didnt see this before I posted my question and I think it will help me solve mine as well so thought I would try to help you out.

This will only make you call the file one time and do both???? Remember to delete the Call BeforeToBefore in the main sub...

Sub AfterToAfter()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
                                        
    If IsArray(FName) Then
        Set BaseWks = Worksheets("After")
        rnum = 2
        For Fnum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(Fnum))
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                With mybook.Worksheets("After")
                    Set sourceRange = .Range("A2:D10")
                End With
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Not enough rows in the sheet. "
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        Set destrange = BaseWks.Range("A" & rnum)
                     With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
            mybook.Close savechanges:=False
            End If
        Next Fnum
    End If
    
    If IsArray(FName) Then
        Set BaseWks = Worksheets("Before")
        rnum = 2
        For Fnum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(Fnum))
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                With mybook.Worksheets("Before")
                    Set sourceRange = .Range("A2:D10")
                End With
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Not enough rows in the sheet. "
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        Set destrange = BaseWks.Range("A" & rnum)
                     With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next Fnum
    End If
ExitTheSub:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub

[brolsen]

Thanks Corey (and davesexcel)!!

I appreciate the time you both took to help me!
Corey, I was trying to do that but kept getting errors! Yours worked for me! Dunno what I was doing wrong, but THANK YOU!!!

[davesexcel]

Try this out.

Sub GetOpenFilename()
    Dim FileToOpen As Variant
    Dim bk As Workbook, ws1 As Worksheet, ws2 As Worksheet, rB As Range, Ra As Range
    Dim wb As Workbook, sh1 As Worksheet, sh2 As Worksheet
    Dim b As String, a As String, rng1 As Range, rng2 As Range
    b = "Before"
    a = "After"
    Set bk = ThisWorkbook
    Set ws1 = bk.Sheets(b)
    Set ws2 = bk.Sheets(a)
    Set rB = ws1.Range("A2")
    Set Ra = ws2.Range("A2")

    FileToOpen = Application.GetOpenFilename("XL Files (*.xl*), *.xl*", , "Open The Workbook")
    Application.ScreenUpdating = 0
    If FileToOpen <> False Then
        Workbooks.Open Filename:=FileToOpen
    End If
    Set wb = ActiveWorkbook
    Set sh1 = wb.Sheets(b)
    Set sh2 = wb.Sheets(a)
    Set rng1 = sh1.Range("A2:D10")
    Set rng2 = sh2.Range("A2:D10")
    rng1.Copy Destination:=rB
    rng2.Copy Destination:=Ra
    wb.Close
End Sub

[davesexcel]

Nothing in my code should have caused your computer to freeze.