How to copy paste data from multiple excel sheet in one workbook in sequence?

[Dave Smith]

Hi,

A big thanks in advance,

I want to create a database using VBA code where I need to copy certain data from multiple excel file in to one excel file.
The user will enter the path of the folder where the multiple excel files are kept, and the code should copy following thing's from multiple excel in to one excel file:
1. file name
2. customer name
3. location
4. product name
5. date

I want to do this process in sequence like 1st enter the file name which is opened in master file, then copy specific cell value from the opened excel file & activate the master file and paste it.
2nd close the opened file open second file and repeat the copy paste procedure.
3rd after copying all the data from all the files present in the folder it should save the master database excel file


I have written the code to get file name from the folder in master data base file as shown below but i am not able to figuring out how to open that file copy and paste in this in sequence

Sub getfolderdfilenames()


Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Dim objfile As Scripting.File
Dim nextrow As Long

Set objFSO = CreateObject("Scripting.FilesystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\SHMEHTA\Desktop\CFD Tool For Request")

nextrow = Database.Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each objfile In objFolder.Files

Database.Cells(nextrow, 2) = objfile.Name
nextrow = nextrow + 1

Next objfile
End Sub

Any Help is appreciated plz....

Regards,
Dave

 

[DanteAmor]

Try this:

Sub getfolderdfilenames()
  Dim objFSO As Scripting.FileSystemObject
  Dim objFolder As Scripting.Folder
  Dim objfile As Scripting.File
  Dim nextrow As Long
  Dim wb As Workbook
  
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FilesystemObject")
  Set objFolder = objFSO.GetFolder("C:\Users\SHMEHTA\Desktop\CFD Tool For Request")
  
  nextrow = Database.Cells(Rows.Count, 1).End(xlUp).Row + 1
  For Each objfile In objFolder.Files
    If InStrRev(objfile, ".xls", , vbTextCompare) > 0 Then
      Set wb = Workbooks.Open(objfile)
      Database.Cells(nextrow, 1) = wb.Sheets(1).Range("B3")
      Database.Cells(nextrow, 2) = objfile.Name
      Database.Cells(nextrow, 3) = wb.Sheets(1).Range("B1")
      Database.Cells(nextrow, 4) = wb.Sheets(1).Range("B2")
      Database.Cells(nextrow, 5) = wb.Sheets(1).Range("B6")
      Database.Cells(nextrow, 6) = wb.Sheets(1).Range("B7")
      nextrow = nextrow + 1
      wb.Close False
    End If
  Next objfile
  ActiveWorkbook.Save
End Sub

 

[Dave Smith]

Try this:

Sub getfolderdfilenames()
  Dim objFSO As Scripting.FileSystemObject
  Dim objFolder As Scripting.Folder
  Dim objfile As Scripting.File
  Dim nextrow As Long
  Dim wb As Workbook
 
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FilesystemObject")
  Set objFolder = objFSO.GetFolder("C:\Users\SHMEHTA\Desktop\CFD Tool For Request")
 
  nextrow = Database.Cells(Rows.Count, 1).End(xlUp).Row + 1
  For Each objfile In objFolder.Files
    If InStrRev(objfile, ".xls", , vbTextCompare) > 0 Then
      Set wb = Workbooks.Open(objfile)
      Database.Cells(nextrow, 1) = wb.Sheets(1).Range("B3")
      Database.Cells(nextrow, 2) = objfile.Name
      Database.Cells(nextrow, 3) = wb.Sheets(1).Range("B1")
      Database.Cells(nextrow, 4) = wb.Sheets(1).Range("B2")
      Database.Cells(nextrow, 5) = wb.Sheets(1).Range("B6")
      Database.Cells(nextrow, 6) = wb.Sheets(1).Range("B7")
      nextrow = nextrow + 1
      wb.Close False
    End If
  Next objfile
  ActiveWorkbook.Save
End Sub

This codes completely works fine for me a big thank you to DanteAmor for sharing this code with me

Sorry, but can you help me in selecting the next file if that file name exists in master database then it should select next file

Sorry if i am little bit troubling you ...

 

[DanteAmor]

Sorry, but can you help me in selecting the next file if that file name exists in master database then it should select next file

If the file name exists exactly where?

 

[Marc L]

Any Help is appreciated plz

Hi, a VBA demonstration for starters to paste to the Master Database worksheet module :​

Sub Demo1()
    Dim oFold As Object, R&, F$
    Set oFold = CreateObject("Shell.Application").BrowseForFolder(0, "", 1, ""):  If oFold Is Nothing Then Exit Sub
    R = 2
    [A1].CurrentRegion.Offset(R).Clear
    Application.ScreenUpdating = False
          F = Dir$(oFold.Self.Path & "\*.xlsx")
    While F > ""
        With Workbooks.Open(oFold.Self.Path & "\" & F, 0).Sheets(1)
             R = R + 1
             Cells(R, 1).Resize(, 6).Value2 = Array(R - 2, F, .[B1].Value, .[B2].Text, .[B6].Text, .[B7].Text)
            .Parent.Close
        End With
          F = Dir$
    Wend
    Application.ScreenUpdating = True
    If R = 2 Then Beep
    Set oFold = Nothing
End Sub

 

[Marc L]

Previous VBA demonstration must be amended like this :​

​

Cells(R, 1).Resize(, 6).Value = Array(R - 2, F, .[B1].Value, .[B2].Text, .[B6].Text, .[B7].Text)

 

[Dave Smith]

If the file name exists exactly where?

means file name exists in master database (File name) Column B and the file which is in the folder both the names are same then it should go to next file

 

[Marc L]

Another codeline should be amended :​

​

If R = 2 Then Beep Else ThisWorkbook.Save

 

[DanteAmor]

means file name exists in master database (File name) Column B and the file which is in the folder both the names are same then it should go to next file

I don't understand what you mean, that is not in your original requirement nor is it in your example image.

 

[DanteAmor]

means file name exists in master database (File name) Column B

If the names are on the sheet, then you need a different macro, not like the one you put in the OP.
You should not read all the files in the folder, only the ones that interest you.

Try this:

Sub GetInfoFromFiles()
  Dim wb As Workbook, p As String, c As Range
  p = "C:\Users\SHMEHTA\Desktop\CFD Tool For Request\"
  Application.ScreenUpdating = False
  For Each c In Database.Range("B3", Database.Range("B" & Rows.Count).End(3))
    If Dir(p & c.Value) <> "" Then
      Set wb = Workbooks.Open(p & c.Value)
      Database.Cells(c.Row, 3).Resize(1, 4).Value = Array(wb.Sheets(1).[b1], wb.Sheets(1).[b2], wb.Sheets(1).[B6], wb.Sheets(1).[B7])
      wb.Close False
    End If
  Next
  ActiveWorkbook.Save
End Sub