I'm getting stuck atm with an excel vba macro.
I like to do the following.
A File is lying on a Network Drive. Ie.
H:\Excel Files\LocationA\
In this folder are many Excel Files all are the same with diffrent data.
I need to read out 2 Cell Values and put them in a new Excel File.
I need the Cel value not the formula or format.
So the Excel Files are Closed
My Script below is working but. It crashes during the process i think in case of opening and close the excel Files. Maybe there are some latency Problems on the Network drive.
Further there are 2 other Locations
H:\Excel Files\LocationB\
H:\Excel Files\LocationC\
If i have finaly working the LocationA I like to copy the loop for the other 2 Location. So maybe i need more Variables.
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPathLiestal As String
Dim myPathMuttenz As String
Dim myPathReinach As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myPathLocationA = "H:\Excel\LocationA\"
'Message Box when tasks are completed
MsgBox "Die Daten werden verarbeitet. Bitte haben sie einen Moment geduld"
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPathLocationA & myExtension)
'Set Dest Path with Ending Extention
Set wsDest = Workbooks("Test.xlsm").Worksheets("2019")
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPathLocationA & myFile)
DestLastRowA = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
'DestLastRowB = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
'Mitarbeiter Namen werden aus der Zelle Q1 kopiert
wb.Worksheets("2019").Range("Q1").Copy
wsDest.Range("A" & DestLastRowA).PasteSpecial xlPasteValues
'Mitarbeiter Stundenkontigent werden aus der Zelle W8 kopiert
wb.Worksheets("2019").Range("W8").Copy
wsDest.Range("B" & DestLastRowA).PasteSpecial xlPasteValues
'Save and Close Workbook
wb.Close SaveChanges:=True
Application.CutCopyMode = False 'Clear Clipboard
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
The heavy lifting of this problem has already been solved here:
Copy and paste data from multiple workbooks to a worksheet in another Workbook
After adapting the code, I got everything to work perfectly in about 15 minutes. However, I then spent the past 3 hours scouring stackoverflow and the rest of the internet trying to figure out how to get it to paste VALUES ONLY instead of bringing over the formatting and formulas with it.
I've tried using .PasteSpecial xlPasteValues, but every time I try this I get an error that says "Compile Error: Expected: end of statement"
I've also tried using .PasteSpecial(xlPasteValues), I get an error that says "Run-time error '1004': Unable to get the PasteSpecial property of the Range class"
My concern is that neither of these methods will work since there wasn't even a .Paste function to begin with.
So when I tried to just add .Paste, it gives me a "Run-time error '438': Object doesn't support this property or method"
Here's the whole code, but I'm mainly just trying to figure out how to do exactly the same with except pasting VALUES ONLY. Thanks!
Sub ConsolidateAllOrdenes()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Choose Target Folder Path"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsm*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = Workbooks.Open("C:\Consolidado\Consolidado_2018-09-05a.xlsm")
Set ws2 = y.Sheets("Consolidado_Orden")
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Copy data on "Orden de Compras" sheet to "consolidado_orden" Sheet in other workbook
With wb.Sheets("Orden de Compras")
lRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("A5:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "I hope that worked!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Replace your copy/paste with this:
With wb.Sheets("Orden de Compras")
Range("A2:M" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Sorry, I'm new to this, but I think I finally figured it out. I believe the range with the copy was lacking a defined workbook and sheet.
Once I specified the workbook and sheet for the copy, there was no issue with putting the paste range on another line and adding .PasteSpecial Paste:=xlPasteValues.
I was also copying 2 lines from each workbook that didn't actually have anything, so I added If WorksheetFunction.CountA(wb.Sheets("Orden de Compras").Range("C5:C200")) <> 0 Then and later Else and End If to skip that workbook if it didn't have anything within the range C5:C200.
I also added Application.CutCopyMode = False because a message box kept popping up after each file.
Replace the copy/paste with this:
With wb.Sheets("Orden de Compras")
If WorksheetFunction.CountA(wb.Sheets("Orden de Compras").Range("C5:C200")) <> 0 Then
lRow = .Range("C" & Rows.Count).End(xlUp).Row
wb.Sheets("Orden de Compras").Range("A5:M" & lRow).Copy
ws2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Else
End If
End With
Thanks to everyone and especially #GMalc for the help!!!
I am trying to create a macro to copy certain cells from one workbook to another. I need to append the new data to data that has already been transferred. I am trying to modify this code to do so, but am not having success:
Sub Consolidate()
'Author: Jerry Beaucaire'
'Date: 9/15/2009 (2007 compatible) (updated 4/29/2011)
'Summary: Merge files in a specific folder into one master sheet (stacked)
' Moves imported files into another folder
' Edited/altered by Jay Chase 6/9/2017
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("BM Condition") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = "C:\Users\jchase.BRYCEWORLD\Desktop\Test\" 'remember final \ in this string"
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*New BM Analysis 3.xls") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
LR = Range("A" & Rows.Count).End(xlUp).Row 'Find last row
Range("P14:S" & LR).EntireRow.Copy .Range("A" & NR)
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
End If
fName = Dir 'ready next filename
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
I have little experience with VBA. Any help with how or why or why not I can do this is appreciated. I am still experimenting; if I have any breakthroughs I will update.
EDIT: so i have realized this code has to be called from the workbook i want to write to, but i need to call it from the workbook i am reading from. Is there a way to modify this script to do so?
I have multiple files with data that need to be transposed into a single master file with all the data into a single row.
I'm a complete noob in programming so if the code I have so far doesn't make any sense, then please feel free to change it
I was able to find this "Loop all excel files in a folder" code from www.TheSpreadsheetGuru.com The code works perfectly fine, it will open up each file individually in the folder and then close it, and then open the next file and close it until it has gone through every file in that folder.
However, I'd like to insert a "copy and paste data" code loop within the loop. So what needs to happen is, the code will open "File1" in the folder, and then copy and paste the data into the "Master File" in cell A4. Then it will close "File1", and then open up "File2" and copy the data into "Master File" in cell A5 and then close "File2". It will repeat this until all files in the folder have been opened/closed.
This is the code I have right now, but I can't get the copy and paste code to work properly. I'm having a hard time figuring out how to set the loop up where the code will know what file it is currently on and setting a counter for the cell of the Master File that it is pasting into.
Sub LLoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "March"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancelhow
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'THIS IS MY COPY AND PASTE CODE (DOESN'T WORK)
Dim row As Integer
While row = 4
Workbooks("Filename:=myPath & myFile").Worksheets("Resin Log").cell("I5") = Workbooks("Workbook1.xlsm").Worksheets("Sheet1").Range("A" & row).Value
Next row
'Save and Close Workbook
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
It is possible to do what you're talking about. I would suggest, trying to just set cell values in the file being created directly
targetworkbook.worksheets(1).Range("A1").value = sourceworkbook.Worksheets(1).Range("C4").value
rather than using .Copy & .Paste so that if the macro takes a while to run you aren't locked out of using Copy/Paste in other applications. If you're still unsure of what to do, try doing it with Record Macro turned on. The generated code will need tweaked, but will give you most of what you need.
Also, be sure to look at this link for some other things to avoid using in your code.
I have a folder in my Desktop with more or less 2000 csv files. Those files have only 1 "Sheet" but the sheet name varies. The only similar thing is that it starts with the word "Tankard".
In that one sheet, I just need to remove Column A and Save it, for all 2000 files. Its only my 2nd month to explore vba automation at work. I'd appreciate if someone can help me. Thanks in advance.
Script:
Sub Tank()
Dim wb As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim SheetName As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
SheetName = "Tankard*"
myPath = "\\ph00winfdfs01p\shares\JoeyC\documents\Roaming\Windows\Desktop\Tank\"
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "Tankard*.csv"
'Target Path with Ending Extention
myfile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
For i = 1 To 201
Set wb = Workbooks.Open(Filename:=myPath & myfile)
';;;;;;;;;;;;;;WRITE YOUR CODE HERE
Sheets("SheetName").Select
Columns("A").Select
Selection.Delete
wb.Close SaveChanges:=True
Next i
'Get next file name
myfile = Dir
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Try to understand what's happening. What this sub does at the moment is opening the first workbook that Dir can find, opening it 201 times and deleting the first column of sheet "Sheetname" every time.
Sheets("SheetName").Select
This selects the sheet with the name "Sheetname", not the name with the value that you set the string Sheetname to. If anything, it should be Sheets(Sheetname) but wildcards don't work here anyways.
Now let's look at the process you're trying to achieve.
myfile = Dir(myPath & myExtension)
sets myfile to the first file that matches your pattern ...\Tankard*.csv
Set wb = Workbooks.Open(Filename:=myPath & myfile)
opens the file and now you can access the workbook via wb
To delete the first column on the sheet I would recommend selecting all that stuff but deleting the range directly:
wb.Sheets(1).Columns(1).Delete 'If you want to actually delete the column
wb.Sheets(1).Columns(1).Clear 'If you want to just remove the values
As you can see you don't need the name of the sheet at all. Now save the workbook:
wb.Close SaveChanges:=True
Now you can set myfile to the next filename using Dir:
myfile = Dir
Then repeat that until there are no more files (at that point Dir will return "". The best way to achieve that is to use a While loop, e.g. like this
While myfile <> ""
'Do stuff here
Wend '(While End)
The advantage over a For loop is that you don't need to know the exact number of files in your folder.
I'll leave it up to you to patch that all together.
Currently i'm trying to consolidate the information from 3000 different xls sheets into one file.
The master file looks like this
http://i.imgur.com/lQWxQxO.png
All the other excels are contained in 1 folder like this. They are only 1 sheet each.
http://i.imgur.com/VxmaLCf.png
and lastly would be that the information inside the files are like this
http:// i.imgur.com/w3erGgN.png
I'm trying to count the number of "pos", "neg" and "neu" inside the files and consolidate on the master sheet and the current way i'm doing is to manually input countif codes while leaving the document open. Is there any other way to make it faster? I've tried sumproduct but it never works. it only returns 0 as i think it might be the wildcard problem.
I think the following code could be of use to me but I'm not sure how to code it such that it works accordingly.
Sub RunCodeOnAllXLSFiles()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\MyDocuments\TestResults"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "Book*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Please help.
Sub Merge()
Path = "C:\path to the folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Found here: http://www.extendoffice.com/documents/excel/456-combine-multiple-workbooks.html