How to copy from multiple workbooks to master file and keep overwrite data
Requirement:
have a code (that i refer to from this forum) that copy data from multiple workbook (in a folder) to one masterfile. My problem is that, it keeps overwriting the data. Example: Person A upload data to master workbook, data is save in the table, but if person B upload his data, it will overwrite the data from Person A. What I want is that, instead of overwriting, it will save the data in a new row, below the data from person A.
Code:
Sub UploadData()
Dim SummWb As Workbook
Dim SceWb As Workbook
'Get folder containing files
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
myFolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Right(myFolderName, 1) <> "\" Then myFolderName = myFolderName & "\"
'Settings
Application.ScreenUpdating = False
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set SummWb = ActiveWorkbook
'Get source files and append to output file
myFileNum = 1
mySceFileName = Dir(myFolderName & "*.*")
myUsedRows = SummWb.Sheets("Master List").UsedRange.Row
Do While mySceFileName <> "" 'Stop once all files found
Application.StatusBar = "Processing: " & mySceFileName
Set SceWb = Workbooks.Open(myFolderName & mySceFileName) 'Open file found
SummWb.Sheets("Master List").Range("D" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("B1").Value
SummWb.Sheets("Master List").Range("E" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("B2").Value
SummWb.Sheets("Master List").Range("F" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("B3").Value
SummWb.Sheets("Master List").Range("G" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("B4").Value
SummWb.Sheets("Master List").Range("H" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("C7").Value
SummWb.Sheets("Master List").Range("I" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("D7").Value
SummWb.Sheets("Master List").Range("J" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("C8").Value
SummWb.Sheets("Master List").Range("K" & myFileNum + myUsedRows).Value = SceWb.Sheets("Survey").Range("D8").Value
'SummWb.Sheets("Master List").Range("C" & myFileNum + myUsedRows).Value = SummWb.Sheets("Load").Range("D5").Value
SceWb.Close (False) 'Close Workbook
myFileNum = myFileNum + 1
mySceFileName = Dir
Loop
'Settings and save output file
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
SummWb.Activate
SummWb.Save 'Uncomment this line if you want to save at the end of the process.
Application.ScreenUpdating = True
End Sub
https://www.ozgrid.com/COMET/editPage.php?page=1474
Solution:
Code:
Sub UploadData()
Dim SummWb As Workbook
Dim SceWb As Workbook
'Get folder containing files
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
myFolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Right(myFolderName, 1) <> "\" Then myFolderName = myFolderName & "\"
'Settings
Application.ScreenUpdating = False
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set SummWb = ActiveWorkbook
'Get source files and append to output file
mySceFileName = Dir(myFolderName & "*.*")
Do While mySceFileName <> "" 'Stop once all files found
Application.StatusBar = "Processing: " & mySceFileName
Set SceWb = Workbooks.Open(myFolderName & mySceFileName) 'Open file found
With SummWb.Sheets("Master List")
.Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B1").Value
.Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B2").Value
.Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B3").Value
.Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("B4").Value
.Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C7").Value
.Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D7").Value
.Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("C8").Value
.Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D8").Value
'.Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Value = SceWb.Sheets("Survey").Range("D5").Value
End With
SceWb.Close (False) 'Close Workbook
mySceFileName = Dir
Loop
'Settings and save output file
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
SummWb.Activate
SummWb.Save 'Uncomment this line if you want to save at the end of the process.
Application.ScreenUpdating = True
End Sub
OR
Code:
Option Explicit
Public x
Sub GetSurveyData()
Dim y(), z, sPath As String, sFiles As String, Files() As String
Dim ws As Worksheet, r As Range
Dim i As Long, ii As Long, iii As Long, lrow As Long
'Get folder containing files
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
sPath = .SelectedItems(1)
'Check if "Cancel" or "X" clicked
If sPath = "" Then
MsgBox "Folder selection canceled, exiting procedure.", , "Operation Canceled."
Exit Sub
End If
End With
If Right(sPath, 1) <> Application.PathSeparator Then sPath = sPath & Application.PathSeparator
sFiles = Dir(sPath & "*.xl*")
'Check there are files in folder
If sFiles = "" Then
MsgBox "No files in selected folder, exiting procedure.", , "Empty Folder."
Exit Sub
End If
'Load array "Files" with the list of files in the folder, then loop through the to extract data
i = 0
Do While sFiles <> ""
i = i + 1: ReDim Preserve Files(1 To i)
Files(i) = sFiles: sFiles = Dir()
Loop
For i = LBound(Files) To UBound(Files)
GetData sPath & Files(i), "A1:D1000"
'Load extracted data into array y
iii = iii + 1: ReDim Preserve y(1 To 8, 1 To iii)
For ii = LBound(x, 1) To LBound(x, 1) + 3
y(ii + 1, iii) = x(1, ii)
Next
For ii = 6 To 7
y(ii - 1, iii) = x(2, ii)
y(ii + 1, iii) = x(3, ii)
Next
Next
'Place data in array y onto "Master List" sheet
With Sheets("Master List")
lrow = .Cells(.Rows.Count, 4).End(xlUp).Row
If lrow < 5 Then lrow = 5
.Rows(5).Resize(lrow - 4).Delete
ReDim z(1 To iii, 1 To 8)
For i = 1 To UBound(z, 1)
For ii = 1 To UBound(z, 2)
z(i, ii) = y(ii, i)
Next
Next
.[d5].Resize(UBound(y, 2), 8) = z
.Columns(4).Resize(, 8).AutoFit
.Activate
End With
End Sub
Public Sub GetData(File As Variant, sRng As String)
Dim rsCon As Object, rsData As Object
Dim szConnect As String, szSQL As String
Dim lCount As Long
' Create the connection string.
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & File & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
szSQL = "SELECT * FROM " & sRng$ & ";"
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and load the data into array x
If Not rsData.EOF Then
x = rsData.getrows
Else
MsgBox "No records returned from : " & File, vbCritical
End If
rsData.Close: Set rsData = Nothing
rsCon.Close: Set rsCon = Nothing
End Sub
Obtained from the OzGrid Help Forum.
Solution provided by Mumps and KjBox.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to copy data from certain columns in a row from one sheet to another |
| How to use VBA to read data from one worksheet and copy to another formatted one |
| How to find a value in a sheet and give back related data to another sheet |
| How to use VBA to transpose data from single column to rows |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.
Gallery
