Luis Diaz
asked on
VBA Excel: Copy Data from one workbook to another v6 csv extension
Hello experts,
I have the following excellent procedure reported at:
https://www.experts-exchange.com/questions/28944137/VBA-Excel-Copy-Data-from-one-workbook-to-another-v5-extension-file.html
I would like to improve it in order to be able to properly copy workbooks with csv file extension.
The procedure import the following csv file in the same cell like this:
Thought when I open the file with excel I have the data in multiple columns.
How can we do in order to properly import csv file knowing that the procedure works perfectly for xlsx and xls extensions.
I attached a dummy file with the related csv file
Thank you very much for your help.
Copy_from_Multiple_Workbooks_V5.xlsm
I have the following excellent procedure reported at:
https://www.experts-exchange.com/questions/28944137/VBA-Excel-Copy-Data-from-one-workbook-to-another-v5-extension-file.html
Dim MostRecent(0 To 1) As Variant
'---> Copy Workbooks from multiple files based on a config sheet
Sub CopyMultipleWorkbooksv5()
Dim wb As Workbook
Dim wb1 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim wbname As String
Dim lr As Long, lr1 As Long
Dim c As Range
'**** New variable
Dim lcol1 As Integer
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
wbname = ActiveWorkbook.Name
Set wb = Workbooks(wbname)
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
For Each c In Range(Range("A2"), Range("A" & Cells.Rows.Count).End(xlUp))
'===========================================================
'-->Check if line has been already launch
'===========================================================
If c.Offset(0, 8).Value <> 1 Then
'===========================================================
'1)-->Add the DestinationWorksheet if doesn't exist
'===========================================================
On Error Resume Next
Set ws = wb.Sheets(c.Offset(0, 4).Value)
On Error GoTo 0
If IsEmpty(ws) Or ws Is Nothing Then
Set ws = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
ws.Name = c.Offset(0, 4).Value
Else
ws.UsedRange.Clear
End If
'===========================================================
'2)-->Open the SourceWorbook and exit sub if it doesn't exist
'===========================================================
On Error Resume Next
'-->SourceWorkbook
'-->To change File Path and prefix workbook
'-->Function Call Open LastestFile in order to call the latest file based on a prefix
strFullPathLatestFile = OpenLatestFile(c.Value, c.Offset(0, 1).Value, c.Offset(0, 3).Value, c.Offset(0, 9).Value)
MsgBox strFullPathLatestFile
Set wb1 = Workbooks.Open(strFullPathLatestFile)
On Error GoTo 0
If IsEmpty(wb1) Or wb1 Is Nothing Then
MsgBox "No Workbook: " & c.Value
Exit Sub
End If
'=====================================================================
'3)-->Lookup the SourceWorksheet and Exit sub if it doesn't exit
'=====================================================================
On Error Resume Next
'-->SourceSheet
'-->To change Prefix SourceSheet
'-->Call Function call GetWorksheet based on a prefix
Set ws1 = wb1.Sheets(GetWorksheet(wb1, c.Offset(0, 2).Value))
On Error GoTo 0
If IsEmpty(ws1) Or ws1 Is Nothing Then
MsgBox "No Worksheet: " & c.Offset(0, 2).Value
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
Exit Sub
End If
'================================================================================
'4)-->Config lastrow and last column of your SourceWorksheet and destination Sheet
'=================================================================================
lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
'lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row **** Replaced
'**** 2 new lines, define last row and last column of source sheet
lr1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
lcol1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Column
'ws1.UsedRange.Copy ws.Range("A" & lr) **** Replaced
'================================================================================
'5)-->Perform the copy
'=================================================================================
'**** 2 new lines, copy and find last row on destination sheet
ws1.Range(c.Offset(0, 5).Value, Cells(lr1, lcol1)).Copy ws.Range(c.Offset(0, 6).Value)
'c.Offset(0, 5).Value = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
ws.UsedRange.ClearFormats
'=====================================================================
'6)-->Perform the row count
'=====================================================================
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
c.Offset(0, 7).Value = lr1
wb1.Close (False)
Set wb1 = Nothing
Set ws1 = Nothing
Set ws = Nothing
MsgBox ("Copy process has been done")
Else
MsgBox c.Offset(0, 2).Value & "hasn't been processed due to already exist flag"
End If
Next
wb.Sheets("3.Parameter-Copy-Workbooks").Select
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
'========>Function: Open the Latest file and return the name
Function OpenLatestFile(filePath, filePrefix, strExt, bRecursive)
MostRecent(1) = 0
MostRecent(0) = "Not Found"
Path = filePath
Set fso = New FileSystemObject
Set fldrs = fso.GetFolder(Path)
If bRecursive Then
MsgBox "You are in the subfolders"
For Each fldr In fldrs.SubFolders
MsgBox "You are in the subfolder " & fldr.Name
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
Next fldr
Else
Set fldr = fso.GetFolder(Path)
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
End If
OpenLatestFile = MostRecent(0)
Set fso = Nothing
End Function
'========>Function 2: Get the Worksheet name based on a worksheet Prefix
' Pass the workbook and the prefix as parameters
Function GetWorksheet(myWorkbook, wsPrefix)
Dim wSheet As Worksheet
Set wsList = myWorkbook.Sheets
For Each wSheet In wsList
wsName = wSheet.Name
' check the prefix
wsName = Mid(wsName, 1, Len(wsPrefix))
' uncomment below line if you want case insensitive search
If LCase(wsName) = LCase(wsPrefix) Then
'If wsName = wsPrefix Then
' Found the 1st worksheet...
GetWorksheet = wSheet.Name
' ...so break out
Exit Function
End If
Next
' Did not find any worksheet with such prefix
GetWorksheet = "" 'ListBox
End Function
Private Sub FindMostRecent(oFldr, strFile)
Set fs = oFldr.Files
For Each f In fs
If f.Name Like strFile And f.DateLastModified > MostRecent(1) Then
MostRecent(0) = f.Path
MostRecent(1) = f.DateLastModified
End If
Next f
End Sub
I would like to improve it in order to be able to properly copy workbooks with csv file extension.
The procedure import the following csv file in the same cell like this:
Thought when I open the file with excel I have the data in multiple columns.
How can we do in order to properly import csv file knowing that the procedure works perfectly for xlsx and xls extensions.
I attached a dummy file with the related csv file
Thank you very much for your help.
Copy_from_Multiple_Workbooks_V5.xlsm
Excel will open a csv and automatically import it to the proper cells. The problem is the csv file you pasted above is a semi-colon separated file.
Hi,
pls try
pls try
Dim MostRecent(0 To 1) As Variant
'---> Copy Workbooks from multiple files based on a config sheet
Sub CopyMultipleWorkbooksv2()
Dim wb As Workbook
Dim wb1 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim wbname As String
Dim lr As Long, lr1 As Long
Dim c As Range
'**** New variable
Dim lcol1 As Integer
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
wbname = ActiveWorkbook.Name
Set wb = Workbooks(wbname)
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
For Each c In Range(Range("A2"), Range("A" & Cells.Rows.Count).End(xlUp))
'===========================================================
'-->Check if line has been already launch
'===========================================================
If c.Offset(0, 8).Value <> 1 Then
'===========================================================
'1)-->Add the DestinationWorksheet if doesn't exist
'===========================================================
On Error Resume Next
Set ws = wb.Sheets(c.Offset(0, 4).Value)
On Error GoTo 0
If IsEmpty(ws) Or ws Is Nothing Then
Set ws = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
ws.Name = c.Offset(0, 4).Value
Else
ws.UsedRange.Clear
End If
'===========================================================
'2)-->Open the SourceWorbook and exit sub if it doesn't exist
'===========================================================
On Error Resume Next
'-->SourceWorkbook
'-->To change File Path and prefix workbook
'-->Function Call Open LastestFile in order to call the latest file based on a prefix
strFullPathLatestFile = OpenLatestFile(c.Value, c.Offset(0, 1).Value, c.Offset(0, 3).Value, c.Offset(0, 9).Value)
MsgBox strFullPathLatestFile
If strFullPathLatestFile Like "*.csv" Then
Set wb1 = Workbooks.OpenText(Filename:=strFullPathLatestFile, DataType:=xlDelimited, Semicolon:=True, Local:=True)
Else
Set wb1 = Workbooks.Open(strFullPathLatestFile)
End If
On Error GoTo 0
If IsEmpty(wb1) Or wb1 Is Nothing Then
MsgBox "No Workbook: " & c.Value
Exit Sub
End If
'=====================================================================
'3)-->Lookup the SourceWorksheet and Exit sub if it doesn't exit
'=====================================================================
On Error Resume Next
'-->SourceSheet
'-->To change Prefix SourceSheet
'-->Call Function call GetWorksheet based on a prefix
Set ws1 = wb1.Sheets(GetWorksheet(wb1, c.Offset(0, 2).Value))
On Error GoTo 0
If IsEmpty(ws1) Or ws1 Is Nothing Then
MsgBox "No Worksheet: " & c.Offset(0, 2).Value
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
Exit Sub
End If
'================================================================================
'4)-->Config lastrow and last column of your SourceWorksheet and destination Sheet
'=================================================================================
lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
'lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row **** Replaced
'**** 2 new lines, define last row and last column of source sheet
lr1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
lcol1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Column
'ws1.UsedRange.Copy ws.Range("A" & lr) **** Replaced
'================================================================================
'5)-->Perform the copy
'=================================================================================
'**** 2 new lines, copy and find last row on destination sheet
ws1.Range(c.Offset(0, 5).Value, Cells(lr1, lcol1)).Copy ws.Range(c.Offset(0, 6).Value)
'c.Offset(0, 5).Value = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
ws.UsedRange.ClearFormats
'=====================================================================
'6)-->Perform the row count
'=====================================================================
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
c.Offset(0, 7).Value = lr1
wb1.Close (False)
Set wb1 = Nothing
Set ws1 = Nothing
Set ws = Nothing
MsgBox ("Copy process has been done")
Else
MsgBox c.Offset(0, 2).Value & "hasn't been processed due to already exist flag"
End If
Next
wb.Sheets("3.Parameter-Copy-Workbooks").Select
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
'========>Function: Open the Latest file and return the name
Function OpenLatestFile(filePath, filePrefix, strExt, bRecursive)
Path = filePath
Set FSO = New FileSystemObject
Set fldrs = FSO.GetFolder(Path)
If bRecursive Then
MsgBox "You are in the subfolders"
For Each fldr In fldrs.SubFolders
MsgBox "You are in the subfolder " & fldr.Name
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
Next fldr
Else
Set fldr = FSO.GetFolder(Path)
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
End If
OpenLatestFile = MostRecent(0)
Set FSO = Nothing
End Function
'========>Function 2: Get the Worksheet name based on a worksheet Prefix
' Pass the workbook and the prefix as parameters
Function GetWorksheet(myWorkbook, wsPrefix)
Dim wSheet As Worksheet
Set wsList = myWorkbook.Sheets
For Each wSheet In wsList
wsName = wSheet.Name
' check the prefix
wsName = Mid(wsName, 1, Len(wsPrefix))
' uncomment below line if you want case insensitive search
If LCase(wsName) = LCase(wsPrefix) Then
'If wsName = wsPrefix Then
' Found the 1st worksheet...
GetWorksheet = wSheet.Name
' ...so break out
Exit Function
End If
Next
' Did not find any worksheet with such prefix
GetWorksheet = "" 'ListBox
End Function
Private Sub FindMostRecent(oFldr, strFile)
Set fs = oFldr.Files
For Each f In fs
If f.Name Like strFile And f.DateLastModified > MostRecent(1) Then
MostRecent(0) = f.Path
MostRecent(1) = f.DateLastModified
End If
Next f
End Sub
Regards
ASKER
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Amazing! Tested and it works!
Thank you very much for your help.
Thank you very much for your help.
ASKER
Rgonzo1971, sorry to disturb you but I have a problem related to the code above.
I perform another test as you can see in my video attached.
I keep two lines in the config sheet, and then I remove the first one and the the loop still take into account the first one as it is shown in the popup however it was removed do you why?
Thank you again for your help.
Copy_Workbooks_6.zip
I perform another test as you can see in my video attached.
I keep two lines in the config sheet, and then I remove the first one and the the loop still take into account the first one as it is shown in the popup however it was removed do you why?
Thank you again for your help.
Copy_Workbooks_6.zip
then try
Dim MostRecent(0 To 1) As Variant
'---> Copy Workbooks from multiple files based on a config sheet
Sub CopyMultipleWorkbooksv2()
Dim wb As Workbook
Dim wb1 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim wbname As String
Dim lr As Long, lr1 As Long
Dim c As Range
'**** New variable
Dim lcol1 As Integer
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
wbname = ActiveWorkbook.Name
Set wb = Workbooks(wbname)
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
For Each c In Range(Range("A2"), Range("A" & Cells.Rows.Count).End(xlUp))
'===========================================================
'-->Check if line has been already launch
'===========================================================
If c.Offset(0, 8).Value <> 1 Then
'===========================================================
'1)-->Add the DestinationWorksheet if doesn't exist
'===========================================================
On Error Resume Next
Set ws = wb.Sheets(c.Offset(0, 4).Value)
On Error GoTo 0
If IsEmpty(ws) Or ws Is Nothing Then
Set ws = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
ws.Name = c.Offset(0, 4).Value
Else
ws.UsedRange.Clear
End If
'===========================================================
'2)-->Open the SourceWorbook and exit sub if it doesn't exist
'===========================================================
On Error Resume Next
'-->SourceWorkbook
'-->To change File Path and prefix workbook
'-->Function Call Open LastestFile in order to call the latest file based on a prefix
strFullPathLatestFile = OpenLatestFile(c.Value, c.Offset(0, 1).Value, c.Offset(0, 3).Value, c.Offset(0, 9).Value)
MsgBox strFullPathLatestFile
If strFullPathLatestFile Like "*.csv" Then
Workbooks.OpenText Filename:=strFullPathLatestFile, DataType:=xlDelimited, Semicolon:=True, Local:=True
Set wb1 = ActiveWorkbook
Else
Set wb1 = Workbooks.Open(strFullPathLatestFile)
End If
On Error GoTo 0
If IsEmpty(wb1) Or wb1 Is Nothing Then
MsgBox "No Workbook: " & c.Value
Exit Sub
End If
'=====================================================================
'3)-->Lookup the SourceWorksheet and Exit sub if it doesn't exit
'=====================================================================
On Error Resume Next
'-->SourceSheet
'-->To change Prefix SourceSheet
'-->Call Function call GetWorksheet based on a prefix
Set ws1 = wb1.Sheets(GetWorksheet(wb1, c.Offset(0, 2).Value))
On Error GoTo 0
If IsEmpty(ws1) Or ws1 Is Nothing Then
MsgBox "No Worksheet: " & c.Offset(0, 2).Value
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
Exit Sub
End If
'================================================================================
'4)-->Config lastrow and last column of your SourceWorksheet and destination Sheet
'=================================================================================
lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
'lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row **** Replaced
'**** 2 new lines, define last row and last column of source sheet
lr1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
lcol1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Column
'ws1.UsedRange.Copy ws.Range("A" & lr) **** Replaced
'================================================================================
'5)-->Perform the copy
'=================================================================================
'**** 2 new lines, copy and find last row on destination sheet
ws1.Range(c.Offset(0, 5).Value, Cells(lr1, lcol1)).Copy ws.Range(c.Offset(0, 6).Value)
'c.Offset(0, 5).Value = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
ws.UsedRange.ClearFormats
'=====================================================================
'6)-->Perform the row count
'=====================================================================
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
c.Offset(0, 7).Value = lr1
wb1.Close (False)
Set wb1 = Nothing
Set ws1 = Nothing
Set ws = Nothing
MsgBox ("Copy process has been done")
Else
MsgBox c.Offset(0, 2).Value & "hasn't been processed due to already exist flag"
End If
MostRecent(1) = 0
Next
wb.Sheets("3.Parameter-Copy-Workbooks").Select
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
'========>Function: Open the Latest file and return the name
Function OpenLatestFile(filePath, filePrefix, strExt, bRecursive)
Path = filePath
Set FSO = New FileSystemObject
Set fldrs = FSO.GetFolder(Path)
If bRecursive Then
MsgBox "You are in the subfolders"
For Each fldr In fldrs.SubFolders
MsgBox "You are in the subfolder " & fldr.Name
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
Next fldr
Else
Set fldr = FSO.GetFolder(Path)
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
End If
OpenLatestFile = MostRecent(0)
Set FSO = Nothing
End Function
'========>Function 2: Get the Worksheet name based on a worksheet Prefix
' Pass the workbook and the prefix as parameters
Function GetWorksheet(myWorkbook, wsPrefix)
Dim wSheet As Worksheet
Set wsList = myWorkbook.Sheets
For Each wSheet In wsList
wsName = wSheet.Name
' check the prefix
wsName = Mid(wsName, 1, Len(wsPrefix))
' uncomment below line if you want case insensitive search
If LCase(wsName) = LCase(wsPrefix) Then
'If wsName = wsPrefix Then
' Found the 1st worksheet...
GetWorksheet = wSheet.Name
' ...so break out
Exit Function
End If
Next
' Did not find any worksheet with such prefix
GetWorksheet = "" 'ListBox
End Function
Private Sub FindMostRecent(oFldr, strFile)
Set fs = oFldr.Files
For Each f In fs
If f.Name Like strFile And f.DateLastModified > MostRecent(1) Then
MostRecent(0) = f.Path
MostRecent(1) = f.DateLastModified
End If
Next f
End Sub
ASKER
Thank you for this proposal.
I retest but I am having the same problem. I think whereis the problem.
As you can see in the code there is a function that openmostrecent file however this function over the full path and prefix workbook file
example:
The prefix Workbook to search should be tititi
However the procedure takes into account spot.csv and spot.csv is one of the most recent file in the folder.
The procedure should take into account the prefixWorkbook and if there are two files with the same prefix in that case it takes the most recent file.
s.
I retest but I am having the same problem. I think whereis the problem.
As you can see in the code there is a function that openmostrecent file however this function over the full path and prefix workbook file
example:
The prefix Workbook to search should be tititi
However the procedure takes into account spot.csv and spot.csv is one of the most recent file in the folder.
The procedure should take into account the prefixWorkbook and if there are two files with the same prefix in that case it takes the most recent file.
s.
then try
Dim MostRecent(0 To 1) As Variant
'---> Copy Workbooks from multiple files based on a config sheet
Sub CopyMultipleWorkbooksv5()
Dim wb As Workbook
Dim wb1 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim wbname As String
Dim lr As Long, lr1 As Long
Dim c As Range
'**** New variable
Dim lcol1 As Integer
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
wbname = ActiveWorkbook.Name
Set wb = Workbooks(wbname)
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
For Each c In Range(Range("A2"), Range("A" & Cells.Rows.Count).End(xlUp))
'===========================================================
'-->Check if line has been already launch
'===========================================================
If c.Offset(0, 8).Value <> 1 Then
'===========================================================
'1)-->Add the DestinationWorksheet if doesn't exist
'===========================================================
On Error Resume Next
Set ws = wb.Sheets(c.Offset(0, 4).Value)
On Error GoTo 0
If IsEmpty(ws) Or ws Is Nothing Then
Set ws = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
ws.Name = c.Offset(0, 4).Value
Else
ws.UsedRange.Clear
End If
'===========================================================
'2)-->Open the SourceWorbook and exit sub if it doesn't exist
'===========================================================
On Error Resume Next
'-->SourceWorkbook
'-->To change File Path and prefix workbook
'-->Function Call Open LastestFile in order to call the latest file based on a prefix
strFullPathLatestFile = OpenLatestFile(c.Value, c.Offset(0, 1).Value, c.Offset(0, 3).Value, c.Offset(0, 9).Value)
MsgBox strFullPathLatestFile
Set wb1 = Workbooks.Open(strFullPathLatestFile)
On Error GoTo 0
If IsEmpty(wb1) Or wb1 Is Nothing Then
MsgBox "No Workbook: " & c.Value
Exit Sub
End If
'=====================================================================
'3)-->Lookup the SourceWorksheet and Exit sub if it doesn't exit
'=====================================================================
On Error Resume Next
'-->SourceSheet
'-->To change Prefix SourceSheet
'-->Call Function call GetWorksheet based on a prefix
Set ws1 = wb1.Sheets(GetWorksheet(wb1, c.Offset(0, 2).Value))
On Error GoTo 0
If IsEmpty(ws1) Or ws1 Is Nothing Then
MsgBox "No Worksheet: " & c.Offset(0, 2).Value
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
Exit Sub
End If
'================================================================================
'4)-->Config lastrow and last column of your SourceWorksheet and destination Sheet
'=================================================================================
lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
'lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row **** Replaced
'**** 2 new lines, define last row and last column of source sheet
lr1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
lcol1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Column
'ws1.UsedRange.Copy ws.Range("A" & lr) **** Replaced
'================================================================================
'5)-->Perform the copy
'=================================================================================
'**** 2 new lines, copy and find last row on destination sheet
ws1.Range(c.Offset(0, 5).Value, Cells(lr1, lcol1)).Copy ws.Range(c.Offset(0, 6).Value)
'c.Offset(0, 5).Value = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
ws.UsedRange.ClearFormats
'=====================================================================
'6)-->Perform the row count
'=====================================================================
wb.Sheets("3.Parameter-Copy-Workbooks").Activate
c.Offset(0, 7).Value = lr1
wb1.Close (False)
Set wb1 = Nothing
Set ws1 = Nothing
Set ws = Nothing
MsgBox ("Copy process has been done")
Else
MsgBox c.Offset(0, 2).Value & "hasn't been processed due to already exist flag"
End If
Next
wb.Sheets("3.Parameter-Copy-Workbooks").Select
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
'========>Function: Open the Latest file and return the name
Function OpenLatestFile(filePath, filePrefix, strExt, bRecursive)
MostRecent(1) = 0
MostRecent(0) = "Not Found"
Path = filePath
Set FSO = New FileSystemObject
Set fldrs = FSO.GetFolder(Path)
If bRecursive Then
MsgBox "You are in the subfolders"
For Each fldr In fldrs.SubFolders
MsgBox "You are in the subfolder " & fldr.Name
FindMostRecent fldr, filePrefix & "*." & strExt
Next fldr
Else
Set fldr = FSO.GetFolder(Path)
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
End If
OpenLatestFile = MostRecent(0)
Set FSO = Nothing
End Function
'========>Function 2: Get the Worksheet name based on a worksheet Prefix
' Pass the workbook and the prefix as parameters
Function GetWorksheet(myWorkbook, wsPrefix)
Dim wSheet As Worksheet
Set wsList = myWorkbook.Sheets
For Each wSheet In wsList
wsName = wSheet.Name
' check the prefix
wsName = Mid(wsName, 1, Len(wsPrefix))
' uncomment below line if you want case insensitive search
If LCase(wsName) = LCase(wsPrefix) Then
'If wsName = wsPrefix Then
' Found the 1st worksheet...
GetWorksheet = wSheet.Name
' ...so break out
Exit Function
End If
Next
' Did not find any worksheet with such prefix
GetWorksheet = "" 'ListBox
End Function
Private Sub FindMostRecent(oFldr, strFile)
Set fs = oFldr.Files
For Each f In fs
If f.Name Like strFile And f.DateLastModified > MostRecent(1) Then
MostRecent(0) = f.Path
MostRecent(1) = f.DateLastModified
End If
Next f
End Sub
ASKER
Thank you very much for this proposal:
I think you took the previous version as it doesn't include the properly copy-paste of csv files.
I compared both codes and I made the revised code which covers almost all the needs.
I have just a tricky think with the following scenario:
Files to copy:
spot-mstt-match.csv
mstt.csv
spot.csv
with the following configuration:
-spot-mstt-match.csv is properly transferred
-mstt.csv is properly transferred
-however when the procedure perform the action of line related to spot.csv it takes the spot-mstt-match.csv and it shoudn't do this.
This is why I would to add a parameter to avoid this in column K.
If column K is equal to 1 then take into account the exact name reported in column b this means that the OpenLastest file should take into account a new condition like this:
Here the last version to take into account.
Thank you again for your help.
I think you took the previous version as it doesn't include the properly copy-paste of csv files.
I compared both codes and I made the revised code which covers almost all the needs.
I have just a tricky think with the following scenario:
Files to copy:
spot-mstt-match.csv
mstt.csv
spot.csv
with the following configuration:
-spot-mstt-match.csv is properly transferred
-mstt.csv is properly transferred
-however when the procedure perform the action of line related to spot.csv it takes the spot-mstt-match.csv and it shoudn't do this.
This is why I would to add a parameter to avoid this in column K.
If column K is equal to 1 then take into account the exact name reported in column b this means that the OpenLastest file should take into account a new condition like this:
Set fldr = FSO.GetFolder(Path)
FindMostRecent fldr, filePrefix & strExt
Instead of:Set fldr = FSO.GetFolder(Path)
FindMostRecent fldr, "*" & filePrefix & "*." & strExt
When Column K is equal to 1.Here the last version to take into account.
Dim MostRecent(0 To 1) As Variant
'---> Copy Workbooks from multiple files based on a config sheet
Sub CopyMultipleWorkbooksv2()
Dim wb As Workbook
Dim wb1 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim wbname As String
Dim lr As Long, lr1 As Long
Dim c As Range
'**** New variable
Dim lcol1 As Integer
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
wbname = ActiveWorkbook.Name
Set wb = Workbooks(wbname)
wb.Sheets("1.Parameter-Copy-Workbooks").Activate
For Each c In Range(Range("A2"), Range("A" & Cells.Rows.Count).End(xlUp))
'===========================================================
'-->Check if line has been already launch
'===========================================================
If c.Offset(0, 8).Value <> 1 Then
'===========================================================
'1)-->Add the DestinationWorksheet if doesn't exist
'===========================================================
On Error Resume Next
Set ws = wb.Sheets(c.Offset(0, 4).Value)
On Error GoTo 0
If IsEmpty(ws) Or ws Is Nothing Then
Set ws = wb.Sheets.Add(After:=Sheets(wb.Sheets.Count))
ws.Name = c.Offset(0, 4).Value
Else
ws.UsedRange.Clear
End If
'===========================================================
'2)-->Open the SourceWorbook and exit sub if it doesn't exist
'===========================================================
On Error Resume Next
'-->SourceWorkbook
'-->To change File Path and prefix workbook
'-->Function Call Open LastestFile in order to call the latest file based on a prefix
strFullPathLatestFile = OpenLatestFile(c.Value, c.Offset(0, 1).Value, c.Offset(0, 3).Value, c.Offset(0, 9).Value)
MsgBox strFullPathLatestFile
If strFullPathLatestFile Like "*.csv" Then
Workbooks.OpenText Filename:=strFullPathLatestFile, DataType:=xlDelimited, Semicolon:=True, Local:=True
Set wb1 = ActiveWorkbook
Else
Set wb1 = Workbooks.Open(strFullPathLatestFile)
End If
On Error GoTo 0
If IsEmpty(wb1) Or wb1 Is Nothing Then
MsgBox "No Workbook: " & c.Value
Exit Sub
End If
'=====================================================================
'3)-->Lookup the SourceWorksheet and Exit sub if it doesn't exit
'=====================================================================
On Error Resume Next
'-->SourceSheet
'-->To change Prefix SourceSheet
'-->Call Function call GetWorksheet based on a prefix
Set ws1 = wb1.Sheets(GetWorksheet(wb1, c.Offset(0, 2).Value))
On Error GoTo 0
If IsEmpty(ws1) Or ws1 Is Nothing Then
MsgBox "No Worksheet: " & c.Offset(0, 2).Value
wb.Sheets("1.Parameter-Copy-Workbooks").Activate
Exit Sub
End If
'================================================================================
'4)-->Config lastrow and last column of your SourceWorksheet and destination Sheet
'=================================================================================
lr = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
'lr1 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row **** Replaced
'**** 2 new lines, define last row and last column of source sheet
lr1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
lcol1 = ws1.Cells.SpecialCells(xlCellTypeLastCell).Column
'ws1.UsedRange.Copy ws.Range("A" & lr) **** Replaced
'================================================================================
'5)-->Perform the copy
'=================================================================================
'**** 2 new lines, copy and find last row on destination sheet
ws1.Range(c.Offset(0, 5).Value, Cells(lr1, lcol1)).Copy ws.Range(c.Offset(0, 6).Value)
'c.Offset(0, 5).Value = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
ws.UsedRange.ClearFormats
'=====================================================================
'6)-->Perform the row count
'=====================================================================
wb.Sheets("1.Parameter-Copy-Workbooks").Activate
c.Offset(0, 7).Value = lr1
wb1.Close (False)
Set wb1 = Nothing
Set ws1 = Nothing
Set ws = Nothing
MsgBox ("Copy process has been done")
Else
MsgBox c.Offset(0, 2).Value & "hasn't been processed due to already exist flag"
End If
MostRecent(1) = 0
Next
wb.Sheets("1.Parameter-Copy-Workbooks").Select
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
'========>Function: Open the Latest file and return the name
Function OpenLatestFile(filePath, filePrefix, strExt, bRecursive)
MostRecent(1) = 0
MostRecent(0) = "Not Found"
Path = filePath
Set fso = New FileSystemObject
Set fldrs = fso.GetFolder(Path)
If bRecursive Then
MsgBox "You are in the subfolders"
For Each fldr In fldrs.SubFolders
MsgBox "You are in the subfolder " & fldr.Name
FindMostRecent fldr, filePrefix & "*." & strExt
Next fldr
Else
Set fldr = fso.GetFolder(Path)
FindMostRecent fldr, filePrefix & "*." & strExt
End If
OpenLatestFile = MostRecent(0)
Set fso = Nothing
End Function
'========>Function 2: Get the Worksheet name based on a worksheet Prefix
' Pass the workbook and the prefix as parameters
Function GetWorksheet(myWorkbook, wsPrefix)
Dim wSheet As Worksheet
Set wsList = myWorkbook.Sheets
For Each wSheet In wsList
wsName = wSheet.Name
' check the prefix
wsName = Mid(wsName, 1, Len(wsPrefix))
' uncomment below line if you want case insensitive search
If LCase(wsName) = LCase(wsPrefix) Then
'If wsName = wsPrefix Then
' Found the 1st worksheet...
GetWorksheet = wSheet.Name
' ...so break out
Exit Function
End If
Next
' Did not find any worksheet with such prefix
GetWorksheet = "" 'ListBox
End Function
Private Sub FindMostRecent(oFldr, strFile)
Set fs = oFldr.Files
For Each f In fs
If f.Name Like strFile And f.DateLastModified > MostRecent(1) Then
MostRecent(0) = f.Path
MostRecent(1) = f.DateLastModified
End If
Next f
End Sub
Thank you again for your help.
you said prefix I supposed the filename was composed of a prefix & some text & suffix that's why
ASKER
Yes, my mistake, and the code works for 95 percent of the case specially when I have datestamp at the end of the name file.
However when I have this scenario which is unique:
spot.csv
and spot-mstt-match.csv
in the same folder I have a clash.
I think it would be great to be able to have the option to used exact name based on a value of column if column K=1 take into account exact name of the value reported in the column used for the prefix else take into account as it is the prefix.
However when I have this scenario which is unique:
spot.csv
and spot-mstt-match.csv
in the same folder I have a clash.
I think it would be great to be able to have the option to used exact name based on a value of column if column K=1 take into account exact name of the value reported in the column used for the prefix else take into account as it is the prefix.
ASKER
@Rgonzo: I think the best is that I create a new question in which I add this new requirement. Let me know if this is ok for you?
A new question would be best
ASKER
Ok, thank you. The new question has been submitted:
https://www.experts-exchan ge.com/que stions/289 66236/VBA- Excel-Copy -Data-from -one-workb ook-to-ano ther-v7-ne w-paramete r-to-by-pa ss-prefix- name.html
Thank you again for your help.
https://www.experts-exchan
Thank you again for your help.