I've read all the answers on Stack Overflow but can't fix this problem.
I'm trying to open each file in a folder, but the Do While loop action correctly opens the first file, performs the task, saves the file and then opens the first file again. How do I get it to go to the next file?
Sub loopmacro()
Dim psheet As Worksheet
Dim imppath As String
Dim impfile As String
Dim exppath As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim thiswb As Workbook
Dim opsheet As Worksheet
Set thiswb = ThisWorkbook
impfile = Sheets("LOOKUPS").Range("C13")
imppath = Dir(impfile)
Application.ScreenUpdating = False
If Dir(impfile) = "" Then
MsgBox "There are no files in the PASTE CSV FOLDER"
Else
Do While imppath <> ""
Set wb1 = Workbooks.Open(impfile)
wb1.Activate
thiswb.Activate
Call clear_paste_csv_data_sheet
wb1.Activate
Range("A1:F1000").Copy
thiswb.Activate
Sheets("Paste CSV here").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wb1.Close
thiswb.Activate
Call calc_data_lines
exppath = thiswb.Sheets("LOOKUPS").Range("C17")
Set wb2 = Workbooks.Add
thiswb.Activate
Sheets("CNV OUTPUT").Range("A1:A1000").Copy
wb2.Activate
Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
wb2.SaveAs Filename:=exppath
wb2.Close
imppath = Dir
Loop
End If
Application.ScreenUpdating = True
End Sub
This line is only referencing the folder and not the file in the folder:
Set wb1 = Workbooks.Open(impfile)
It should be:
Set wb1 = Workbooks.Open(impfile & imppath)
This indicates that you've probably got your variable names around the wrong way.
It looks like you should have:
impPath = Sheets("LOOKUPS").Range("C13")
and
impfile = Dir(imppath)
then this will read logically:
Set wb1 = Workbooks.Open(imppath & impfile)
Related
I have hundreds of Excel (Microsoft® Excel® for Microsoft 365 MSO (16.0.14326.20702) 32-bit ) files in a folder which have one sheet in common.
For example- Let's consider the sheet as "data".
I want to pull specific cells (C2:C15) out of each of them and transpose them into a separate "masterfile".
This code runs unsuccessfully.
Sub ExtractData()
Dim masterfile As Workbook
Dim wb As Workbook
Dim directory As String
Dim fileName As String
Dim NextRow As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set masterfile = ThisWorkbook
directory = masterfile.Worksheets("Sheet1").Range("E1")
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
If fileName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(directory & fileName)
wb.Worksheets("data").Range("C2:C15").Copy
masterfile.Activate
NextRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
Worksheets("Sheet1").Range("C" & NextRow).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
wb.Close savechanges:=False
End If
fileName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled, Please Check!"
End Sub
Some suggestions:
Sub ExtractData()
Dim masterSheet As Worksheet
Dim wb As Workbook
Dim directory As String
Dim fileName As String, cDest As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set masterSheet = ThisWorkbook.Worksheets("Sheet1")
directory = masterSheet.Range("E1").Value
'### ensure trailing path separator ###
If Right(directory, 1) <> "\" Then directory = directory & "\"
'first paste location
Set cDest = masterSheet.Cells(masterSheet.Rows.Count, "C").End(xlUp).Offset(1)
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
If fileName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(directory & fileName)
wb.Worksheets("data").Range("C2:C15").Copy
cDest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Set cDest = cDest.Offset(1) 'next paste row
wb.Close savechanges:=False
End If
fileName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled, Please Check!"
End Sub
I have a list of *.xlsm file names on a sheet named "DB" in range E961 to E1010 (50 rows) and I'm trying to create a macro that runs through this list and open the corresponding files in the set directory, runs some code and close the file, moving on to the next file on the list - repeating this operation every 5 minutes.
The directory contains 400+ xlsm files, and the list in E961 will typically be less than 50 files - so I'm not trying to open all the files in the directory. That already happens once a day at a set time.
But I am trying to open these "shortlisted" files and update them every 5 minutes for example. I tried different combinations of code but can't seem to get it working.
The main file containing this code is also in the same directory to allow relative linking to the other 400+ files, hence the ThisWorkbook.Path code.
Edited code below:
Sub UPDATE()
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("DB")
Dim inputRange As Range
Set inputRange = .Range("E961", .Cells(.Rows.Count, 5).End(xlUp))
End With
Dim directory As String: directory = ThisWorkbook.Path & "\"
Dim fileName As String
Dim r As Range
Dim xlwb As Workbook
For Each r In inputRange
If r <> vbNullString Then
fileName = Dir(directory & r & ".xl??*")
Set xlwb = Workbooks.Open(directory & fileName)
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
If Range("A4") > Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0) Then
Worksheets("DB").Range("A4:L4").Select
Worksheets("DB").Range("A4").Activate
Selection.Copy
Sheets("DB").Select
Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(1). _
PasteSpecial Paste:=xlPasteValues, _
SkipBlanks:=True, Transpose:=False
Application.CutCopyMode = False
Else
End If
If Range("A4") = Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0) Then
Worksheets("DB").Range("A4:L4").Select
Worksheets("DB").Range("A4").Activate
Selection.Copy
Sheets("DB").Select
Sheets("DB").Cells(Rows.Count, "A").End(xlUp).Offset(0). _
PasteSpecial Paste:=xlPasteValues, _
SkipBlanks:=True, Transpose:=False
Application.CutCopyMode = False
End If
xlwb.Close True
End If
Next r
Application.ScreenUpdating = True
End Sub
The error comes from "Set xlwb = (sht.Cells(Row, 1).Value)" because it is trying to open a sheet as a workbook, but I have no idea how to fix it... or everything is wrong ...
Thanks for the help!
Try this piece it should work thought it will only open and close workbooks until you give it some code to work them:
Option Explicit
Sub UPDATE()
Application.ScreenUpdating = False
'if you are only using here your wb and sht variables, use a With, there is no need to use variables
With ThisWorkbook.Worksheets("DB")
Dim inputRange As Range
'It is preferable to do xlUp because you could find some empty cells in between.
Set inputRange = .Range("E961", .Cells(.Rows.Count, 5).End(xlUp))
End With
Dim directory As String: directory = ThisWorkbook.Path & "\"
Dim fileName As String
Dim r As Range
Dim xlwb As Workbook
For Each r In inputRange
If r <> vbNullString Then
fileName = Dir(directory & r & ".xl??*") 'don't know if your cell has the extension
Set xlwb = Workbooks.Open(directory & fileName)
'some code
xlwb.Close False 'False won't save the workbook, use True if you want it to be saved.
End If
Next r
Application.ScreenUpdating = True
End Sub
I'm looking to do the following:
CommandButton in a destination Worksheet opens a source file (dialog box to choose which one)
Finds a worksheet (always the same name - "Performance") within the source file
Copies a range of cells (actually a couple of separate ranges - to be added)
Makes sure destination sheet (which has the same name as cell I2 in source sheet) exists
Pastes values to same ranges in destination Worksheet
Closes source file
I have this so far:
Private Sub CommandButton1_Click()
Dim SourceFile As String
Dim SourceBook As Workbook
Dim DestinationBook As Workbook
Dim desiredName As String
Set DestinationBook = ThisWorkbook
SourceFile = Application.GetOpenFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Set SourceBook = Workbooks.Open(SourceFile)
SourceBook.Sheets("Performance").Activate
desiredName = ActiveSheet.Range("I2")
Application.CutCopyMode = True
SourceBook.ActiveSheet.Range("E25:I64").Copy
DestinationBook.Activate
If WorksheetExists = False Then
MsgBox "Couldn't find " & desiredName & " sheet within destination workbook"
Call SourceBook.Close(False)
Exit Sub
Else
Range("E25:I64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Call SourceBook.Close(False)
End If
End Sub
Function WorksheetExists() As Boolean
Dim sh As Object
For Each sh In DestinationBook.Worksheets
If sh.Name = desiredName Then WorksheetExists = True: sh.Activate
Exit For
Next
End Function
I'm getting Run-time error '424': Object Required
Any suggestions...?
Thanks in advance!
Here is a modification of your latest code. Notice these additions: 1) "Option Explicit" ensures you've properly declared all variables, 2) variables have been assigned to the important workbooks, worksheets, and ranges, 3) needed variables are passed to the WorkSheetExists function. For this to work there should be sheets named "Performance" and "testSheet" in the DestinationBook, and "testSheet" in I2 of the SourceBook. Remember, that this is just an attempt to "get you going" so I expect you'll need to modify.
Option Explicit
Sub test()
Dim SourceFile As String
Dim SourceBook As Workbook, performanceSh As Worksheet
Dim DestinationBook As Workbook
Dim desiredName As String
Set DestinationBook = ThisWorkbook
SourceFile = Application.GetOpenFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Set SourceBook = Workbooks.Open(SourceFile)
Set performanceSh = SourceBook.Sheets("Performance")
desiredName = performanceSh.Range("I2")
Application.CutCopyMode = True
performanceSh.Range("E25:I64").Copy
If WorksheetExists(DestinationBook, desiredName) = False Then
MsgBox "Couldn't find " & desiredName & " sheet within destination workbook"
SourceBook.Close(False)
Exit Sub
Else
Range("E25:I64").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
SourceBook.Close(False)
End If
End Sub
Function WorksheetExists(destWk As Workbook, theName As String) As Boolean
Dim sh As Object
For Each sh In destWk.Worksheets
If sh.Name = theName Then WorksheetExists = True: sh.Activate
Exit For
Next
End Function
I have 1 Master Excel Workbook that I need to populate from other excel files.... Basically Open 1 by 1 each file from One folder and copy paste on the Master Workbook... I wrote One macro.. but it still have some flows... I don't know how to make it work
Option Explicit
Sub fill()
Dim wb As Workbook, wb2 As Workbook, mywb As Workbook
Dim sPath As String, sFilename As String
Dim NbRows As Integer, rg As Range
Set wb = ThisWorkbook
'Application.ScreenUpdating = False
Set mywb = Workbooks("C:\Users\cbensoussan.FGC\Desktop\MASTER FOLDER.xlsx")
sPath = "F:\Blotters\OPT\2014\Jan\"
sFilename = Dir(sPath & "*.xls*")
Do While Len(sFilename) > 0
Set wb2 = Workbooks.Open(sPath & sFilename)
Range("A2:AO2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
mywb.Select
Range("A2").Select
Range(Selection, Selection.End(xlDown) + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wb2.Close False
sFilename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Thank you for your help
Something like this (untested)
Option Explicit
Sub fill()
Dim wb As Workbook, wb2 As Workbook, mywb As Workbook
Dim sPath As String, sFilename As String
Dim NbRows As Integer, rg As Range, rgCopy as range
Set wb = ThisWorkbook
'Application.ScreenUpdating = False
'if not already open:
Set mywb = Workbooks.Open("C:\Users\cbensoussan.FGC\Desktop\MASTER FOLDER.xlsx")
'or if already open:
'Set mywb = Workbooks("MASTER FOLDER.xlsx")
sPath = "F:\Blotters\OPT\2014\Jan\"
sFilename = Dir(sPath & "*.xls*")
Do While Len(sFilename) > 0
Set wb2 = Workbooks.Open(sPath & sFilename)
with wb2.Activesheet
Set rgCopy = .Range("A2:AO" & .cells(.rows.count, 1).End(xlUp).Row)
end with
mywb.activesheet.cells(rows.count, 1).end(xlUp). _
Resize(rgCopy.Rows.Count, rgCopy.Columns.Count).Value = rgCopy.Value
wb2.Close False
sFilename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Suppose I have a workbook1.xlsm with multiple worksheets and full of various formulas. I want to create a new workbook2.xlsx which would look exactly the same as workbook1 but in all the cells would be values instead of formulas.
I have this macro to copy one sheet from workbook1:
Sub nowe()
Dim Output As Workbook
Dim FileName As String
Set Output = Workbooks.Add
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Przestoje").Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
End Sub
but the problem is it copies only one worksheet and does not name it like it was in worksheet1. I cannot figure it out.
Yet another problem is that worksheet2 is being opened afterwards. I do not want to do this.
How can I solve these problems?
I would do that as simply as possibly, without creating new workbook and copying sheets to it.
Few simple steps: taking into consideration thisworkbook >> for each worksheet within thisworkbook >> copy+paste values of used range within worksheet >> save as new workbook as xlsx type >> open back base workbook >> and finally close one we created.
The code will be simple and looks as follows:
Sub nowe_poprawione()
Dim Output As Workbook
Dim Current As String
Dim FileName As String
Set Output = ThisWorkbook
Current = ThisWorkbook.FullName
Application.DisplayAlerts = False
Dim SH As Worksheet
For Each SH In Output.Worksheets
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook
Workbooks.Open Current
Output.Close
Application.DisplayAlerts = True
End Sub
This should allow you to keep all the formatting, column widths, and only the values.
Option Explicit
Sub copyAll()
Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim firstCell
Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
Application.DisplayAlerts = False
Dim i As Integer
For Each sh In Source.Worksheets
Dim newSheet As Worksheet
' select all used cells in the source sheet:
sh.Activate
sh.UsedRange.Select
Application.CutCopyMode = False
Selection.Copy
' create new destination sheet:
Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count))
newSheet.Name = sh.Name
' make sure the destination sheet is selected with the right cell:
newSheet.Activate
firstCell = sh.UsedRange.Cells(1, 1).Address
newSheet.Range(firstCell).Select
' paste the values:
Range(firstCell).PasteSpecial Paste:=xlPasteColumnWidths
Range(firstCell).PasteSpecial Paste:=xlPasteFormats
Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
' delete the sheets that were originally there
While Output.Sheets.Count > Source.Worksheets.Count
Output.Sheets(1).Delete
Wend
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
Output.Close
Application.ScreenUpdating = True
End Sub
Something like this would work to cycle through and copy all sheets after adding the workbook:
dim i as integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Activate
ThisWorkbook.Worksheets(i).Select
Cells.Copy
Output.Activate
Dim newSheet As Worksheet
Set newSheet = Output.Worksheets.Add()
newSheet.Name = ThisWorkbook.Worksheets(i).Name
newSheet.Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
Note that this doesn't handle removing default sheets that automatically get created when the workbook gets created.
Also, worksheet2 is actually being opened (though not named til SaveAs) as soon as you call this:
Set Output = Workbooks.Add
Just close it after saving:
Output.Close
Something like this would work to cycle through and copy all sheets after adding the workbook - it builds on mr.Reband's answer, but with a few bells and whistles. Among other things it will work if this is in a third workbook (or an add-in etc), it deletes the default sheet or sheets that were created, it ensures the order of the sheets is the same as the original, etc:
Option Explicit
Sub copyAll()
Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim firstCell
Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
Application.DisplayAlerts = False
Dim i As Integer
For Each sh In Source.Worksheets
Dim newSheet As Worksheet
' select all used cells in the source sheet:
sh.Activate
sh.UsedRange.Select
Application.CutCopyMode = False
Selection.Copy
' create new destination sheet:
Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count))
newSheet.Name = sh.Name
' make sure the destination sheet is selected with the right cell:
newSheet.Activate
firstCell = sh.UsedRange.Cells(1, 1).Address
newSheet.Range(firstCell).Select
' paste the values:
Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
' delete the sheets that were originally there
While Output.Sheets.Count > Source.Worksheets.Count
Output.Sheets(1).Delete
Wend
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
Output.Close
Application.ScreenUpdating = True
End Sub