I've got this code but it pastes the cell formatting from the original document into the master file, how can I remove the formatting from the output please?
Option Explicit
Sub CopyPastefiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
'turn screen updating off - makes program faster
'Application.ScreenUpdating = False
'location of the folder in which the desired TDS files are
MyFolder = "U:\Documents\DeleteMe\Sycle\"
Set StartSht = ActiveSheet
Set StartSht = Workbooks("masterfile.xlsx").Sheets("Sheet1")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name to Column 1
Workbooks.Open Filename:=MyFolder & objFile.Name
Set WB = ActiveWorkbook
'print TOOLING DATA SHEET(TDS): values to Column 2
With WB
For Each ws In .Worksheets
StartSht.Cells(i + 1, 10) = objFile.Name
With ws
.Range("e6").Copy StartSht.Cells(i + 1, 4)
.Range("e7").Copy StartSht.Cells(i + 1, 5)
.Range("e8").Copy StartSht.Cells(i + 1, 6)
End With
i = i + 1
'move to next file
Next ws
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'move to next file
Next objFile
'turn screen updating back on
'Application.ScreenUpdating = True
End Sub
thanks for you help.
Instead of using .Copy to directly paste the values into the destination, you can use .PasteSpecial Paste:=xlPasteValues.
I.e. something like
.Range("e6").Copy
StartSht.Cells(i + 1, 4).PasteSpecial Paste:=xlPasteValues
for your first line.
Or you can just set the cell equal to the range you're copying, as suggested in the comments on your question.
.StartSht.Cells(i + 1, 4) = .Range("E6")
Related
I have a master Excel file which will be used as a reference to get the data from different sheet names from different Excel files in a folder,
I've searched the net and could not get a solution. Is there a way to get all the sheet names and paste it per row starting from A2 and A1 and which will reflect its file name without the extension?
Here is what I have so far:
Sub SheetNames()
Columns(1).Insert
For I = 1 To Sheets.Count
Cells(I, 1) = Sheets(I).Name
Next I
End Sub
You can try this code. It will save everything in first sheet of your master workbook:
Sub SheetNames()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim currentWorkbook, wb As Workbook
Dim i, j As Integer
Set currentWorkbook = ActiveWorkbook
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the current folder object
Set objFolder = objFSO.GetFolder(currentWorkbook.Path)
i = 1
j = 2
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'we filter filenames, so we get only excel files
'note that second condition is to prevent from using cached workbook associated with opened workbook
'it starts with ~$
If objFile.Name Like "*.xlsx" And Not objFile.Name Like "~$*.xlsx" _
And Not objFile.Name = currentWorkbook.Name Then
'get the name of a workbook in the first row
currentWorkbook.Worksheets(1).Cells(1, i).Value = objFile.Name
'open workbook
Set wb = Workbooks.Open(currentWorkbook.Path & "/" & objFile.Name)
'loop through sheets and get their names into cells
For j = 2 To wb.Worksheets.Count + 1
currentWorkbook.Worksheets(1).Cells(j, i).Value = wb.Worksheets(j - 1).Name
Next
'close workbook without saving changes
wb.Close (False)
i = i + 1
End If
Next objFile
End Sub
I'm trying to create a range name in a number of excel files, and then write the file names and paths out to another excel. The files/paths are written correctly, but the range name doesn't appear to be created in the file. Can you tell me where I'm going wrong?
Sub directlisting()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim cell As Range
Dim RangeName As String
Dim CellName As String
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("\\xxxxxxxxxxx\testdata\Transfer")
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'open file if an Excel file
If Right(objFile, 4) = "xls*" Or Right(objFile, 3) = "xl*" Then
Application.Workbooks.Open (objFile)
'create range name
RangeName = "PVS"
CellName = "A4:AG27"
Set cell = Worksheets("PVS").Range(CellName)
objFile.Names.Add Name:=RangeName, RefersTo:=cell
'Save the file
Application.DisplayAlerts = False
objFile.Save
objFile.Close
Application.DisplayAlerts = True
End If
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.path
i = i + 1
Next objFile
End If
End Sub
I tested this and it seemed to work for me. The main idea was to be more explicit with the workbook/worksheets and what you're calling them on:
Sub directlisting()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim cell As Range
Dim RangeName As String, CellName As String
Dim i As Integer
Dim tempWB As Workbook, mainWB As Workbook
Dim mainWS As Worksheet
'Assuming this is running from a "main" workbook
Set mainWB = ActiveWorkbook
Set mainWS = mainWB.ActiveSheet
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("D:\User\Documents\Test") ' CHANGE TO YOUR PATH
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'open file if an Excel file
If Right(objFile, 4) = "xlsx" Or Right(objFile, 3) = "xl*" Then
Set tempWB = Application.Workbooks.Open(objFile)
'create range name
RangeName = "PVS"
CellName = "A4:AG27"
Set cell = tempWB.Worksheets("PVS").Range(CellName)
'ActiveWorkbook.Names.Add Name:="PVS", RefersToR1C1:="=PVS!R11C8:R18C14"
tempWB.Names.Add Name:=RangeName, RefersTo:=cell
'print file name
mainWS.Cells(i + 1, 1) = tempWB.Name
'print file path
mainWS.Cells(i + 1, 2) = tempWB.Path
i = i + 1
'Save the file
Application.DisplayAlerts = False
tempWB.Save
tempWB.Close
Application.DisplayAlerts = True
End If ' Right (objFile, 4) ...
Next objFile
End Sub
Small note: I had to change the ... = "xls*" Or Right ... to ... = "xlsx" Or ..., because for some reason it wouldn't open the .xlsx file. Curious. In any case, let me know if you get any errors or weird issues!
Also, I moved the part where you save the workbook name and path inside the If statement, so only if the file opens, will it mark it. Just tweak that line if you want to note every file, whether or not it opens.
I have code which opens multiple files in a folder, prints the name of that file into column 1 (continuing down the column) of a masterfile, closes the current file, and moves onto the next one until the folder is empty.
There is information in cell J1(preferably written as 1,10) of all of the files that I want to copy while the file is open, paste into column 4 (continuing down the column, equal with the names of each file), and continue to close the current file and move on.
I cannot figure out how to copy just one cell since a range requires information over multiple rows. Here is my working code for looping through files and just printing their name. Any ideas? Thanks!
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet
Dim i As Integer
Dim LastRow As Integer, erow As Integer
'Speed up process by not updating the screen
'Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = ActiveSheet
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name
Sht.Cells(i + 1, 1) = objFile.Name
i = i + 1
Workbooks.Open fileName:=MyFolder & objFile.Name
End If
'Macro recording of manual copy/paste but I want to apply on general scale
'Range("J1").Select
'Selection.Copy
'Windows("masterfile.xlsm").Activate
'Range("D2").Select
'ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=False
Next objFile
'Application.ScreenUpdating = True
End Sub
Incorporate this, renaming "MySheet":
Option Explicit
Sub CopyFromSheets()
Dim WB As Workbook
Dim ws As Worksheet
Dim i As Integer
Set WB = ActiveWorkbook
i = 1
With WB
For Each ws In .Worksheets
With ws
.Range("J1").Copy Workbooks("masterfile.xlsm").Sheets("MySheet").Cells(i, 10) 'Rename Mysheet
i = i + 1
End With
Next ws
End With
End Sub
This should do it:
Option Explicit
Sub LoopThroughDirectory()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim Sht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
Dim LastRow As Integer, erow As Integer
Application.ScreenUpdating = False
MyFolder = "C:\Users\trembos\Documents\TDS\progress\"
Set Sht = Workbooks("masterfile.xlsm").Sheets("MySheet")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name
Workbooks.Open Filename:=MyFolder & objFile.Name
Set WB = ActiveWorkbook
With WB
For Each ws In .Worksheets
Sht.Cells(i + 1, 1) = objFile.Name
With ws
.Range("J1").Copy Sht.Cells(i + 1, 4)
End With
i = i + 1
Next ws
.Close SaveChanges:=False
End With
End If
Next objFile
Application.ScreenUpdating = True
End Sub
I am trying to create For Each loop for a several workbooks; however I am not able to set the workbook name in the array and thus resulted into this. I'm stuck in trying to concatenate the workbook name.
Here's my code:
'Open all .csv file in folder location
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
For Each objFile In objFolder.Files
If InStr(objFile, ".csv") Then
Workbooks.Open (objFile)
End If
Next
' Declare variables
Dim WrkBkPrm As Workbook
Dim WrkBkSrc As Workbook
Dim WrkShtPrm As Worksheet
Dim WrkShtSrc As Worksheet
Dim TextSrc(4) As String
Dim SrcRng As Range
Dim DRng As Range
' Assign values to TextSrc() Array
TextSrc(0) = Cable
TextSrc(1) = Care
TextSrc(2) = MSD
TextSrc(3) = Business
'Set WrkBkPrm and WrkShtPrm values
Set WrkBkPrm = Workbooks("MasterFile" & ".xlsm")
Set WrkShtPrm = WrkBkPrm.Worksheets("Canvas")
'Activate Canvas Sheet
WrkBkPrm.Activate
WrkShtPrm.Select
Application.ScreenUpdating = False
'Start For Each Loop
For Each Src In TextSrc()
Set WrkBkSrc = Workbooks(Src & ".csv")
Set WrkShtSrc = WrkBkSrc.Worksheets(Src)
'Copy loop for 1st section
For i = 2 To 49
For j = 7 To 25
Set SrcRng = WrkShtSrc.Cells(i, j)
Set DRng = WrkShtPrm.Cells(i, j)
If SrcRng <> "" Then
DRng.Value = SrcRng.Value
End If
Next j
Next i
Next Src
Application.ScreenUpdating = True
I'd suggest you work on the file as soon as you get hold of the relevant info you need.
Something like:
Dim wb As Workbook
For Each objFile In objFolder.Files
If InStr(objFile.Name, ".csv") <> 0 Then
Set wb = Workbooks.Open(Thisworkbook.Path & "\" & objFile.Name)
'~~> Do your cool stuff with the opened CSV File
wb.Close False '~~> Close without saving
Set wb = Nothing '~~> Clean up although most of the time not necessary
End If
Next
As for the route you took, for you to use For Each Loop on TxtSrc, you need to declare it as variant.
Something like:
Dim TxtSrc As Variant, Src As Variant
TxtSrc = Array("Cable", "Care", "MSD", "Business")
For Each Src In TxtSrc
Set wb = Workbooks.Open(Thisworkbook.Path & "\" & Src & ".csv")
'~~> More cool stuff here
wb.Close False
Set wb = Nothing
Next
It is important that provide the correct argument for the Workbook Open Method.
You should always include the complete path in string format. HTH.
So I was trying to create a list of excel files in a folder (file name and path) and then use a For loop to copy and paste a specified worksheet for all of the files listed into a specified worksheet in the excel workbook that contains the macro. So far everything works except for the fact that the same file keeps getting copied and pasted over instead of all the files. The macro loops for the correct number of times, but it's not using all the excel files.
Here's the code:
First part for listing the files in the folder
Private Sub btn_LeaveReport()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("D:\Administration\Time Sheets")
i = 2
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 2) = objFile.Name
'print file path
Cells(i + 1, 3) = objFile.Path
i = i + 1
Next objFile
End Sub
and this is the part for the loop
Private Sub btn_PullData()
'Declared Variables
Dim wbk As Workbook
Dim i As Integer
Dim StartAt As Integer
Dim EndAt As Integer
Dim CopyPath As String
Dim CopyPathRow As Integer
Dim iRow As Integer
'Ranges
StartAt = 1
EndAt = Val(ThisWorkbook.Worksheets("LeaveReport").Range("A1"))
CopyPathRow = 3
CopyPath = ThisWorkbook.Worksheets("LeaveReport").Range("C" & CopyPathRow)
iRow = 3
'Loop de loop
For i = StartAt To EndAt
Application.ScreenUpdating = False
Set wbk = Workbooks.Open(CopyPath)
Sheets("TIMESHEET").Select
Range("C12:S34").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Pastebin").Select
Range("a" & iRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
iRow = iRow + 39
CopyPathRow = CopyPathRow + 1
wbk.Close True
Next i
Sheets("Pastebin").Select
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
MsgBox "Timesheet Data Imported"
End Sub
Based on the source of the error, i.e. same file being used, I'm guessing the issue lies with the part that has this:
CopyPath = ThisWorkbook.Worksheets("LeaveReport").Range("C" & CopyPathRow)
and is "supposed" to update in the For loop via this:
CopyPathRow = CopyPathRow + 1
Move the line
CopyPath = ThisWorkbook.Worksheets("LeaveReport").Range("C" & CopyPathRow)
Inside the loop, that value of CopyPath is never being changed, but the value of CopyPathRow is.
Edit: I wouldn't call this recursion either.