Need VBA to open multiple sheets, copy, and paste certain values

T

thejohn11

New Member
Joined
Mar 16, 2012
Messages
8
Hey Guys,
I know you have gotten this one a bunch before, but I can't find a way to do the couple things I need this to do. I'm really close however, so it shouldn't take more than 5 minutes hopefully.

What I need.
Open multiple files at one time, copy and paste certain cells in those files, to the corresponding cells in my master file. It cannot overwrite the old data lines, it simply needs to paste the new information in the master below the old information. Then close the files.

here's what I have so far, this code works... it's missing 2 things.
Does not open multiple files and does not paste new information below old information.

Sub ImportData()
Dim strFile As String
MsgBox "Select Expense Reports"
strFile = Application.GetOpenFilename("Excel-files,*.xlsm ; *.xls ; *.xlsx", _
1, "Select Expense Reports", , False)
If strFile = "False" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim oWorkBook As Workbook
Dim oSheet As Worksheet
Dim oMaster As Worksheet
Dim i As Long
On Error Resume Next
Set oMaster = ThisWorkbook.Worksheets("Master")
Set oWorkBook = Workbooks.Open(strFile, ReadOnly:=True)
Set oSheet = oWorkBook.Worksheets("End Report")
ThisWorkbook.Save
i = oMaster.Cells.SpecialCells(xlCellTypeLastCell).Row
If i > 1 Then
oMaster.Range("A:J" & i).Interior.Pattern = xlNone
End If
i = oSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
oMaster.Range("A4").Value = oSheet.Range("C13").Value
oMaster.Range("B4").Value = oSheet.Range("F8").Value
oMaster.Range("C4").Value = oSheet.Range("F9").Value
oMaster.Range("D4").Value = oSheet.Range("C9").Value
oMaster.Range("E4").Value = oSheet.Range("C10").Value
oMaster.Range("F4").Value = oSheet.Range("C14").Value
oMaster.Range("G4").Value = oSheet.Range("C16").Value
oMaster.Range("H4").Value = oSheet.Range("C17").Value
oMaster.Range("I4").Value = oSheet.Range("C18").Value
oMaster.Range("J4").Value = oSheet.Range("C19").Value
oMaster.Range("K4").Value = oSheet.Range("C20").Value
oMaster.Range("L4").Value = oSheet.Range("C22").Value
oMaster.Range("M4").Value = oSheet.Range("F12").Value
oWorkBook.Close (False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub


Please Help
Thank you!
 
Last edited:
Sort by date Sort by votes
Adding a LastRow variable as shown below will allow you to copy to the end of existing data.
Code: 
    lr = Sheets("Master").UsedRange.Rows.Count + 1
    oMaster.Range("A" & lr).Value = oSheet.Range("C13").Value
    oMaster.Range("B" & lr).Value = oSheet.Range("F8").Value
    oMaster.Range("C" & lr).Value = oSheet.Range("F9").Value
    oMaster.Range("D" & lr).Value = oSheet.Range("C9").Value
    oMaster.Range("E" & lr).Value = oSheet.Range("C10").Value
    oMaster.Range("F" & lr).Value = oSheet.Range("C14").Value
    oMaster.Range("G" & lr).Value = oSheet.Range("C16").Value
    oMaster.Range("H" & lr).Value = oSheet.Range("C17").Value
    oMaster.Range("I" & lr).Value = oSheet.Range("C18").Value
    oMaster.Range("J" & lr).Value = oSheet.Range("C19").Value
    oMaster.Range("K" & lr).Value = oSheet.Range("C20").Value
    oMaster.Range("L" & lr).Value = oSheet.Range("C22").Value
    oMaster.Range("M" & lr).Value = oSheet.Range("F12").Value
Will the other workbooks that you want to copy from always use the same "C" and "F" cells of the "End Report" worksheet?
 
Upvote 0
Yes. The files I'm pulling from will be a standard template, everything should be in the same place every time. How to I get to open multiple files?
 
Upvote 0
Try this, make sure the workbook MASTER is not in the same folder:
Code: 
Option Explicit

Sub ImportData()
Dim fNAME As String, fPATH As String
Dim oWorkBook As Workbook, NR As Long
Dim oMaster As Worksheet, oSheet As Worksheet

MsgBox "Select Expense Reports Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        fPATH = .SelectedItems(1) & "\"
    Else
        Exit Sub
    End If
End With

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
Set oMaster = ThisWorkbook.Worksheets("Master")
NR = oMaster.Range("A" & Rows.Count).End(xlUp).Row + 1

fNAME = Dir(fPATH & "*.xl*")            'finds any Excel file in chosen folder

Do While Len(fNAME) > 0
    Set oWorkBook = Workbooks.Open(fNAME, ReadOnly:=True)
    Set oSheet = oWorkBook.Worksheets("End Report")
    If NR > 1 Then oMaster.Range("A:J" & NR).Interior.Pattern = xlNone
    oMaster.Range("A" & NR).Value = oSheet.Range("C13").Value
    oMaster.Range("B" & NR).Value = oSheet.Range("F8").Value
    oMaster.Range("C" & NR).Value = oSheet.Range("F9").Value
    oMaster.Range("D" & NR).Value = oSheet.Range("C9").Value
    oMaster.Range("E" & NR).Value = oSheet.Range("C10").Value
    oMaster.Range("F" & NR).Value = oSheet.Range("C14").Value
    oMaster.Range("G" & NR).Value = oSheet.Range("C16").Value
    oMaster.Range("H" & NR).Value = oSheet.Range("C17").Value
    oMaster.Range("I" & NR).Value = oSheet.Range("C18").Value
    oMaster.Range("J" & NR).Value = oSheet.Range("C19").Value
    oMaster.Range("K" & NR).Value = oSheet.Range("C20").Value
    oMaster.Range("L" & NR).Value = oSheet.Range("C22").Value
    oMaster.Range("M" & NR).Value = oSheet.Range("F12").Value
    oWorkBook.Close (False)
    NR = NR + 1
        
    fNAME = Dir         'get next filename with same filter
Loop                    'repeat until no more filenames

ThisWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Upvote 0
Hey. I got a runtime error 1004

It says
"Expense-_report-Dylan.xls' could not be found. Check the spelling of the file name, and verify that the file location is correct."
"If you are trying to open the file from your list of most recently used files, make sure that the file has not been renamed, moved or deleted."

Then when I go to debug it highlights this line of code
Set oWorkBook = Workbooks.Open(fNAME, ReadOnly:=True)

Is there a way you can do it that doesn't require an entire file? Maybe one that just opens multiple workbooks?
 
Upvote 0
Sorry, my bad:
Rich (BB code): 
Set oWorkBook = Workbooks.Open(fPATH & fNAME, ReadOnly:=True)
 
Upvote 0
I'm getting another error as I try to run the updated macro.
This time the debugger stops at
oMaster.Range("A:M" & NR).Interior.Pattern = xlNone

Can you please edit this so I can select multiple workbooks, and not have to select an entire folder.
 
Upvote 0
Maybe:
Rich (BB code): 
If NR > 1 Then oMaster.Range("A" & NR).Resize(,10).Interior.Pattern = xlNone
 
Upvote 0
Thank you. Final working code is
PHP: 
Option Explicit

Sub Import_Expense_Reports()
Dim fNAME As String, fPATH As String
Dim oWorkBook As Workbook, NR As Long
Dim oMaster As Worksheet, oSheet As Worksheet

MsgBox "Select Expense Reports Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count > 0 Then
        fPATH = .SelectedItems(1) & "\"
    Else
        Exit Sub
    End If
End With

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
Set oMaster = ThisWorkbook.Worksheets("Master")

' Hardcode to beginning of sheet.  NR is row index:
NR = oMaster.Range("A" & Rows.Count).End(xlUp).Row

fNAME = Dir(fPATH & "*.xl*")            'finds any Excel file in chosen folder

Do While Len(fNAME) > 0
    Set oWorkBook = Workbooks.Open(fPATH & fNAME, ReadOnly:=True)
    Set oSheet = oWorkBook.Worksheets("End Report")
    If NR > 1 Then oMaster.Range("A" & NR).Resize(, 10).Interior.Pattern = xlNone
    oMaster.Range("A" & NR).Value = oSheet.Range("C13").Value
    oMaster.Range("B" & NR).Value = oSheet.Range("F8").Value
    oMaster.Range("C" & NR).Value = oSheet.Range("F9").Value
    oMaster.Range("D" & NR).Value = oSheet.Range("C9").Value
    oMaster.Range("E" & NR).Value = oSheet.Range("C10").Value
    oMaster.Range("F" & NR).Value = oSheet.Range("C14").Value
    oMaster.Range("G" & NR).Value = oSheet.Range("C16").Value
    oMaster.Range("H" & NR).Value = oSheet.Range("C17").Value
    oMaster.Range("I" & NR).Value = oSheet.Range("C18").Value
    oMaster.Range("J" & NR).Value = oSheet.Range("C19").Value
    oMaster.Range("K" & NR).Value = oSheet.Range("C20").Value
    oMaster.Range("L" & NR).Value = oSheet.Range("C22").Value
    oMaster.Range("M" & NR).Value = oSheet.Range("F12").Value
    oWorkBook.Close (False)
    NR = NR + 1
        
    fNAME = Dir         'get next filename with same filter
Loop                    'repeat until no more filenames

ThisWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

yearego021
  • Solved
VBA to Save as PDF broken with unwanted deleting of tabs.
Replies
7
Views
264
Artik
Artik
L
  • Solved
Attempting importing sheet from data file into destination file.
2
Replies
16
Views
346
Alex Blakenburg
A
T
  • Solved
Copy all sheet contents from selected workbook and paste into current workbook sheets of the same name
Replies
2
Views
257
TurpsUK
T
V
  • Question Question
Copy Range from Multiple Sheets and Paste Link into a Single Sheet
Replies
2
Views
484
vbascientist
V
willow1985
  • Solved
VBA For workbooks.open, if file doesnt exist goto on error
Replies
3
Views
194
Logit
Logit

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