Excel copy from file to file macro not working - vba

I have to copy data from multiple excel files named with numbers (1.xlsx, 2.xlsx, 3.xlsx, etc). I wrote this macro. It runs. But no copy happens, the main workbook in which I ran the macro remains empty.
Sub filecopy()
' The macro is running in the main file, which I saved as .xlsm
' This main.xlsm is in the same folder as the files from which I copy the data
Dim Filename As String, Pathname As String,xx as Double
Activesheet.Usedrange.Clear 'I delete the current contents of the sheet
Pathname = ActiveWorkbook.Path
Filename = Dir(Pathname & "*.xlsx")
xx = 1 'the first column where the contents of the first file goes
Do While Len(Filename) > 0
Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1"
Cells(2, xx).Formula = "='[" & Filename & "]Sheet1'!B2"
Cells(3, xx).Formula = "='[" & Filename & "]Sheet1'!C3"
xx = xx + 1 'next file next column
Filename = Dir()
Loop
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'every formula goes to value
MsgBox "Work Complete", vbInformation
End Sub

There are 2 errors in your code:
1. \ is missing -> filename is empty
Replace Filename = Dir(Pathname & "*.xlsx") with Filename = Dir(Pathname & "\*.xlsx")
2. the formula is not correct -> not complete filename
Change your formulas e.g. Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1" with this Cells(1, xx).Formula = "='" & Pathname & "\[" & Filename & "]Sheet1'!A1"

What about a solution like this:
Pathname = ActiveWorkbook.Path 'Be sure is the rigth path
Filename = Dir(Pathname & "\*.xlsx") 'I've addedd a "\"
xx = 1
Do While Len(Filename) > 0
If Filename <> ThisWorkbook.Name Then
Set mFile = Workbooks.Open(Pathname & "\" & Filename)
Else
GoTo NextFile
End If
With mFile.ActiveSheet 'Use the sheet you need here
Cells(1, xx) = .Cells(1, 1).Value
Cells(2, xx) = .Cells(2, 1).Value
Cells(3, xx) = .Cells(3, 1).Value
End With
xx = xx + 1 'next file next column
Application.DisplayAlerts = False
mFile.Close savechanges:=False
Application.DisplayAlerts = True
Set mFile = Nothing
NextFile:
Filename = Dir()
Loop

Related

How can I delete a file based on cell value?

I'm having trouble deleting a file based on cell value.
I get an error message on the line with the Kill command below:
Kill path & r.Offset(1, -4) & "\" & r.Offset(1, -3)
Any ideas?
Sub INACTIVE_files()
Const path = "C:\Users\NikolouzosD\AppData\Local\Temp\vbakillfunction\"
Dim r As Range
Dim x As Integer
Set r = Cells(1, 5)
Do Until r = ""
If UCase(r.value) = "INACTIVE" Then
Kill path & r.Offset(1, -4) & "\" & r.Offset(1, -3)
End If
Set r = r.Offset(1, 0)
Loop
End Sub
The code starts from cell E1 and looks for INACTIVE files in the same column, until there's no more files to look for.
Then, it checks the folder name (Column A), combines it with the Cube (Column B)
and puts both of them in a path:
path = "C:\Users\NikolouzosD\AppData\Local\Temp\vbakillfunction\"
so for example:
for cell E2 which is INACTIVE, the path should be:
C:\Users\NikolouzosD\AppData\Local\Temp\vbakillfunction\WPO 17 02 04 3MMT All Periods\BG023104.txt
It then deletes the INACTIVE files (Cubes) from the appropriate folder.
Wrap your path in double quotes to avoid issues with spaces in filenames and folders.
Even better is to put the path in a string variable so you can debug it easily
Outside your loop:
Dim strPath As String
Inside your if block:
strPath = """" & path & r.Offset(1,-4) & "\" & r.Offset(1,-3) & """"
Debug.Print strPath ' Ctrl-G to view results
Kill strPath
EDIT - add a check for file before deleting
Under Tools | References
Add a reference to Windows Script Hosting
Then at top of sub code add
Dim fso as New FileSystemObject
Replace your Kill command with a check for existence
If fso.FileExists(strPath) Then
Kill strPath
Else
Msgbox "File Doesn't Exist: " & strPath
End If
UPDATED FOR CONTINUE TO NEXT FILE
Change loop to be:
Do Until r = ""
If UCase(r.value) = "INACTIVE" AND fso.FileExists(strPath) Then
Kill strPath
End If
Set r = r.Offset(1, 0)
Loop
It works!
I've commented out some parts of the code that were used for checking if a file exists.
Sub delete_INACTIVE_files()
Const path = "C:\Users\Dn\AppData\Local\Temp\vbakillfunction\"
Dim r As Range
Set r = Cells(1, 5)
Do Until r = ""
If UCase(r.Value) = "INACTIVE" Then
If Dir(path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt") <> "" Then 'Does the file exist?
'MsgBox "file" & path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt" & " exists"
Kill path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt"
'Else
'MsgBox "file" & path & r.Offset(0, -4) & "\" & r.Offset(0, -3) & ".txt" & " not here"
End If
End If
Set r = r.Offset(1, 0)
Loop
End Sub

VBA Copy and Paste Transpose data from Multiple columns

I have multiple Timesheet workbooks set up which has Employee Name and multiple columns for different hour types (eg. Base Hours, Holiday Pay, Sick Pay). See image .
I need code to be able to copy for each employee the type of hours (heading) and the value into 4 columns.
eg.
Employee 1 Base Hours 37.50
Employee 1 Sick Hours 15.00
Employee 1 Group Leader 20.00
Employee 2 Base Hours 50.00
Employee 2 Holiday Pay 60.00
I have some code which copies the data to a template currently but stuck on how to copy it as above.
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Sheets("Timesheet").Range("A9:N" & Range("A" &
Rows.Count).End(xlUp).Row).Copy
Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport").Range("A"
& Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
NewBook.Close savechanges:=True
End Sub
Example Timesheet File
Example Upload Template
Using the function at the link I posted, something like this (untested):
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Dim rngData, p, shtDest As Worksheet
Set shtDest = Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
'<edited> range containing your data
With wb.Sheets("Timesheet")
Set rngData = .Range("A9:N" & _
.Range("A" & .Rows.Count).End(xlUp).Row)
End with
'</edited>
p = UnPivotData(rngData, 2, True, False) '<< unpivot
'put unpivoted data to sheet
With shtDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(UBound(p, 1), UBound(p, 2)).Value = p
End With
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
NewBook.Close savechanges:=True
End Sub

Running VBA code written in Windows on a Mac

I've written some VBA to go through a folder and consolidate spreadsheets onto one masterfile. One of the first things I needed to do was to look for all files in a folder with the extension .xl*.
I wrote this on a Windows box, and now someone wants to run this on a Mac.
I have changes the line from
Fname = Dir(ThisWorkbook.Path & "/*.xl*")
to
Fname = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xl*")
but I get a: run time error 68 - device not available error
How can I get this line running on a Mac?
For reference here is the complete code:
Sub Consolidation()
Application.ScreenUpdating = False
'find last record in mastersheet
Set destsheet = ThisWorkbook.Worksheets("Consolidated")
Set MyRange = Worksheets("Consolidated").Range("C" & "1")
lngLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
'looks for files with the follwing extension
'Fname = Dir(ThisWorkbook.Path & "/*.xl*")
Fname = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xl*")
'cycles through the folder
Do While Fname <> ""
If Fname <> ThisWorkbook.Name Then
Application.StatusBar = "Processing: " & Fname
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
n = 0
m = 0
'adds recods to the next avaibale row
'destsheet.Range("B4").Offset(lngLastRow + 1, 1) = originsheet.Range("E4").Value
destsheet.Range("C" & lngLastRow + 1) = originsheet.Range("E4").Value
destsheet.Range("D" & lngLastRow + 1) = originsheet.Range("E5").Value
destsheet.Range("E" & lngLastRow + 1) = originsheet.Range("E6").Value
destsheet.Range("F" & lngLastRow + 1) = originsheet.Range("E7").Value
destsheet.Range("G" & lngLastRow + 1) = originsheet.Range("E8").Value
destsheet.Range("H" & lngLastRow + 1) = originsheet.Range("E9").Value
destsheet.Range("I" & lngLastRow + 1) = originsheet.Range("E10").Value
lngLastRow = lngLastRow + 1
wkbkorigin.Close SaveChanges:=False 'close current file
End If
'stips when out of files to import
Fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Try setting the Files and Folders permission on MacOS Security Preferences pane for Excel.

my code runs and works on some excel workbooks but not all of them, why? VBA

I have a weird problem with my code VBA.
I am using excel 2010, i wrote a code which works perfectly on multiple source except some.
my code object is to copy the same cell from the same sheet from multiple workbooks and paste it into a destination workbook as a column.
My code runs on 50 workbooks without any problem, except 2.
Notice that those 2 are the same sample as the others, but of course different values.
If I ad those 2 workbooks with the other 50, I have an error message 'Error of execution'1004' and I should then stop the process.
the yellow line stand on a the formula :
myFile = Dir(myPath & myExtension)
Set y = Workbooks.Open(destFullpath)
`With y.Sheets("Feuil1").Range("A" & i + 1)
**.Formula = "='" & "[" & myFile & "]Para RF'!L2" 'date**
.Value = .Value
y.Sheets("Feuil1").Range("A" & i + 1).NumberFormat = "dd/mm/yy;#" ' <-- to specify that it is a date format
End With`
Do you have an idea why can this problem occur?
what should i do? Is there anything to change with the settings etc?
Note That I have tried to save those 2 as excel without macros, so xlsx and did not run.
I tried to unprotect the sheets: did not run
I broke the link between them and other one: this didn't help either!!!
what can it be??
Thank you!!
This is the entire code :
Sub LoopAllExcelFilesInFolderr()
'PURPOSE: To loop through all Excel files in a user specified folder and
perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim destFullpath As String
Dim myExtension As String
DimFldrPicker As FileDialog
Dim y As Workbook
Dim i As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Application.DisplayAlerts = False
'Retrieve Target Folder Path From User
myPath = "Z:\VBA\para_macro\"
destFullpath = "Z:\VBA\base-macro.xlsx"
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Set y = Workbooks.Open(destFullpath)
For i = 1 To y.Sheets("Feuil1").Range("M1")
'Ensure Workbook has opened before moving on to next line of code
DoEvents
With y.Sheets("Feuil1").Range("A" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!L2" 'date devis
.Value = .Value
y.Sheets("Feuil1").Range("A" & i + 1).NumberFormat = "dd/mm/yy;#" ' <-- to specify that it is a date format
End With
With y.Sheets("Feuil1").Range("B" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!E11" 'date d'installation
.Value = .Value
End With
With y.Sheets("Feuil1").Range("c" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!H5" 'type
.Value = .Value
End With
With y.Sheets("Feuil1").Range("D" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!H8" 'montant final
.Value = .Value
.NumberFormat = "0.000"
End With
With y.Sheets("Feuil1").Range("E" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!K8" 'montant tarif
.Value = .Value
.NumberFormat = "0.000"
End With
With y.Sheets("Feuil1").Range("F" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!K10" 'remise
.Value = .Value
.NumberFormat = "0.000"
End With
With y.Sheets("Feuil1")
.Range("G2:G" & .Cells(.Rows.count, "F").End(xlUp).Row).Formula = "=$F2/$E2"
y.Sheets("Feuil1").Range("G2:G" & .Cells(.Rows.count, "F").End(xlUp).Row).NumberFormat = "0.00%"
End With
With y.Sheets("Feuil1").Range("H" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!D6" 'société
.Value = .Value
End With
With y.Sheets("Feuil1").Range("I" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!F8" 'ville
.Value = .Value
End With
With y.Sheets("Feuil1").Range("J" & i + 1)
.Formula = "='" & "[" & myFile & "]Para RF'!G5" 'nom vendeur
.Value = .Value
End With
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir()
Next
'Save and Close Workbook
y.Close saveChanges:=True
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You're not iterating 50 workbooks. You're iterating 50 file names.
.Formula = "='" & "[" & myFile & "]Para RF'!L2"
Error 1004 on this line means myFile somehow contains invalid characters, or (more likely) that there is no worksheet named Para RF in that workbook.
Try typing ='[that file name.xlsx]Para RF'!L2 directly in a cell (in any workbook). You'll see this:
So, Verify that your formula contains a valid path, workbook, range name, and cell reference.
If there is such a Para RF sheet in the failing workbook, make sure there's no leading/trailing spaces.

VBA - Trouble with Loop Structure for File Searching and Copying

I'm trying to develop a macro on one of my spreadsheets that will take the value of Column B (2502-13892-33 for example), starting at Row 3, and search the source folder listed in column A for that file (using Wildcards before and after the value in column B. Once it finds that file, it needs to use FileCopy to copy the file into the Destination Folder listed in Column C, but only after renaming the file in the form of "Column E"_"Original Filename (A252_2502-13892-33 for example).
I think I have worked out the code to make this work because when I tested it, it functioned exactly like I expected it to, found the file, copied it to the new destination with the PREFIX from column E and the underscore added to the filename. The problem is that it just stops after the first file, which leads me to believe something is wrong with the structure of my loop.
My code is as follows:
Sub MoveFiles()
Dim SourcePath As String
Dim DestPath As String
Dim PartNum As String
Dim PLISN As String
Dim LastRow As Long
Dim i As Long
Dim filename As String
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
PLISN = Cells(i, "E").Value
PartNum = Cells(i, "B").Value
If Right(Cells(i, "A").Value, 1) <> Application.PathSeparator Then
SourcePath = Cells(i, "A").Value & Application.PathSeparator
Else
SourcePath = Cells(i, "A").Value
End If
If Right(Cells(i, "C").Value, 1) <> Application.PathSeparator Then
DestPath = Cells(i, "C").Value & Application.PathSeparator
Else
DestPath = Cells(i, "C").Value
End If
If Dir$(SourcePath & "*" & PartNum & "*") = "" Then
Cells(i, "D").Value = "Source file does not exist."
ElseIf Dir$(DestPath & PLISN & "_" & "*" & PartNum & ".pdf") <> "" Then
Cells(i, "D").Value = "File already exists."
Else
filename = Dir$(SourcePath & "*" & PartNum & "*" & ".pdf")
'Copy the file
FileCopy SourcePath & filename, DestPath & PLISN & "_" & filename
Cells(i, "D").Value = "File Copied to new location"
End If
Next i
End Sub
I had accidentally left my DestinationPath blank for the 2nd and 3rd lines of the excel sheet. That was what was giving me just the "\" as the destination path. Seems to be working properly now.
As someone mentioned below in one of the comments, stepping through my code in the debugger was extremely helpful to solving this problem. My final code has some structural changes, in that I no longer have columns for SourcePath and DestPath, and instead use a folder dialog box to have the user select both of those.
The code for selecting my Source and Destination Folders:
Sub SourceFolder()
Dim lCount As Long
Dim rCount As Long
SourcePath = vbNullString
DestPath = vbNullString
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Title = "Source Path"
.Show
For lCount = 1 To .SelectedItems.Count
SourcePath = .SelectedItems(lCount)
MsgBox (SourcePath)
Next lCount
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Title = "Destination Path"
.Show
For rCount = 1 To .SelectedItems.Count
DestPath = .SelectedItems(rCount)
MsgBox (DestPath)
Next rCount
End With
End Sub
The code for actually going out to the SourcePath, searching for the filename located in Column A (including with wildcards before and after), copying it to the DestinationPath, and renaming it with ColumnB's Value, followed by an underscore, and then ColumnA's Value is as follows:
Option Explicit
Public SourcePath As String
Public DestPath As String
Dim PartNum As String
Dim PLISN As String
Sub MoveFiles()
Dim LastRow As Long
Dim i As Long
Dim filename As String
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
PLISN = Cells(i, "B").Value
PartNum = Cells(i, "A").Value
If Right(SourcePath, 1) <> Application.PathSeparator Then
SourcePath = SourcePath & Application.PathSeparator
Else
SourcePath = SourcePath
End If
If Right(DestPath, 1) <> Application.PathSeparator Then
DestPath = DestPath & Application.PathSeparator
Else
DestPath = DestPath
End If
If Dir$(SourcePath & "*" & "*" & PartNum & "*") = "" Then
Cells(i, "C").Value = "Source file does not exist."
ElseIf Dir$(DestPath & PLISN & "_" & "*" & PartNum & "*" & ".pdf") <> "" Then
Cells(i, "C").Value = "File already exists."
Else
filename = Dir$(SourcePath & "*" & PartNum & "*" & ".pdf")
'Copy the file
FileCopy SourcePath & filename, DestPath & PLISN & "_" & filename
Cells(i, "C").Value = "File Copied to new location"
End If
Next i
End Sub