Code below saved files to a static location and renamed them based on an index 'File names' starting on position A1.
Instead of them being saved to a constant location, can I make it save to a subfolder matching another value on the 'File names' sheet? This would be under B1 on the 'File names' sheet with names like, "John", "Dave", "Kathy" etc.
I appreciate any help!
Public Sub SaveTemplate()
Const strSavePath As String = "C:\My Documents\"
Const strTemplatePath As String = "C:\My Documents\template.xls"
Dim rngNames As Excel.Range
Dim rng As Excel.Range
Dim wkbTemplate As Excel.Workbook
Set rngNames = ThisWorkbook.Worksheets("File Names").Range("A1:A200").Values
Set wkbTemplate = Application.Workbooks.Open(strTemplatePath)
For Each rng In rngNames.Cells
wkbTemplate.SaveAs strSavePath & rng.Value
Next rng
wkbTemplate.Close SaveChanges:=False
End Sub
Like this:
Public Sub SaveTemplate()
Const strSavePath As String = "C:\My Documents\"
Const strTemplatePath As String = "C:\My Documents\template.xls"
Dim rngNames As Range, rng As Range
Set rngNames = ThisWorkbook.Worksheets("File Names").Range("A1:A200")
With Application.Workbooks.Open(strTemplatePath)
For Each rng In rngNames.Cells
'include folder name from Col B
.SaveAs strSavePath & rng.Offset(0, 1).Value & "\" & rng.Value
Next rng
.Close SaveChanges:=False
End With
End Sub
Related
I am working on a Macro to extract data from different rows (there are some blank rows) but I want it to search and extract instead of from a range to extract from columns A-D this can be from (A1:D100) then to stop the loop if A(x) where the content of X is "Results". Then to loop to the next workbook.
Sub tgr()
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim rCopy As Range
Dim sFolder As String
Dim sFile As String
Dim lRow As Long
Set wbDest = ThisWorkbook 'The workbook where information will be copied into
Set wsDest = wbDest.Worksheets("Sheet1") 'The worksheet where information will be copied into
sFolder = "C:\Path\" 'The folder path containing the xlsx files to copy from
'would like sFolder to be the root folder and also
' search for any "*.xlsx" contained inside C:\temp
lRow = 1 'The starting row where information will be copied into
'Adjust the folder path to ensure it ends with \
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
'Get the first .xlsx file in the folder path
sFile = Dir(sFolder & "*.xlsx")
'Begin loop through each file in the folder
Do While Len(sFile) > 0
'Open the current workbook in the folder
With Workbooks.Open(sFolder & sFile)
'Copy over the formulas from A1:C3 from only the first
' worksheet into the destination worksheet
Set rCopy = .Sheets(1).Range("C9:D26")
wsDest.Cells(lRow, "A").Resize(rCopy.Rows.Count, rCopy.Columns.Count).Formula = rCopy.Formula
'Advance the destination row by the number of rows being copied over
lRow = lRow + rCopy.Rows.Count
.Close False 'Close the workbook that was opened from the folder without saving changes
End With
sFile = Dir 'Advance to the next file
Loop
End Sub
Code 1 is used to find the FIRST occurrence of the string we search for:
Option Explicit
Sub test()
Dim rngSearch As Range, Position As Range
Dim strSearch As String
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .Range("A1:D100") '<- Set the range i want to search in
strSearch = "Test" '<- Set the string i want to search for
Set Position = rngSearch.Find(strSearch) '<- Search for string in range
If Not Position Is Nothing And .Range("A" & Position.Row).Value = "Results" Then '<- Check if string appears in the range and the value in column A and row where the string is "Results"
'Code here
End If
End With
End Sub
Code 2 is used to search the whole range and check ALL occurrence of string we search for:
Option Explicit
Sub test()
Dim rngSearch As Range, cell As Range
Dim strSearch As String
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .Range("A1:D100") '<- Set the range i want to search in
strSearch = "Test" '<- Set the string i want to search for
For Each cell In rngSearch
If cell.Value = strSearch And .Range("A" & cell.Row).Value = "Results" Then
'Code here
End If
Next cell
End With
End Sub
I am trying to come up with a routine that copies only certain files out of a directory, and all sub-directories, and pastes each copied file into a destination directory. I came up with the code below, which copies all files, in a filtered list, into a destination folder, but I can't figure out how to do a recursive loop through the hierarchy. Any guidance on this would be greatly appreciated.
Sub CopyFilteredFiles()
Dim rng As Range, cell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim lastChar As Integer
Dim fileName As String
DestinationFolder = "C:\Users\ryans\OneDrive\Desktop\AllYAML\"
Set sht = ActiveSheet
LastRow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
Set rng = Range("D14:D" & LastRow)
Set FSO = CreateObject("scripting.filesystemobject")
For Each cell In rng.SpecialCells(xlCellTypeVisible)
If cell.Value <> "" Then
CopyFile = cell.Value
Debug.Print cell.Value
lastChar = InStrRev(CopyFile, "\")
fileName = Mid(CopyFile, lastChar + 1, 199)
On Error Resume Next
FSO.CopyFile Source:=CopyFile, Destination:=DestinationFolder & fileName
End If
Next cell
End Sub
I need to generate many .xls files
renamed as the name contained in row A1, A2, A3 ....
example: NAME1.xls, NAME2.xls ...
and the new generated file must contain only the cells contained in the markers ####
(see IMG...cellD4:T32)
the markers change manually entered by me.
I tried this code only to save new .xls files
but it does not work....I do not know how to do the rest
Private Sub CommandButton1_Clickl()
Dim path As String
Dim filename1 As String
path = "C:\"
filename1 = Range("A1").Text
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=path & filename1 & ".xls", FileFormat:=x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
Okay here ya go. This should grab the chunk of the original workbook you're looking for and save it as multiple new workbooks.
Option 1 removes formatting
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim arr() As Variant
arr = wksht.Range("C3:U33").value
Dim wb As Workbook
Dim i As Long
For i = 1 To ActiveSheet.Range("A1").End(xlDown).Row
Set wb = Application.Workbooks.Add
wb.Sheets(1).Range("A1", Cells(UBound(arr), UBound(arr, 2))).value = arr
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
Option 2 keeps formatting
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim dataRange As Range
Set dataRange = wksht.Range("C3", wksht.UsedRange.SpecialCells(xlCellTypeLastCell))
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
Set wb = Application.Workbooks.Add
dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
but note that the starting point is still C3 based on the example given.
Option 3 keeps formatting and selects the range between the 2 cells with #### in them
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
Set wb = Application.Workbooks.Add
dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
Option 5 keeps row heights and column widths
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim newDataRange As Range
Dim wb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
For i = 1 To wksht.Range("A" & wksht.Rows.Count).End(xlUp).Row
Set wb = Application.Workbooks.Add
Set newDataRange = wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.Rows.Count, dataRange.Columns.Count))
dataRange.Copy newDataRange
For j = 1 To dataRange.Columns.Count
newDataRange.Cells(1, j).ColumnWidth = dataRange.Cells(1, j).ColumnWidth
Next j
For k = 1 To dataRange.Rows.Count
newDataRange.Cells(k, 1).RowHeight = dataRange.Cells(k, 1).RowHeight
Next k
wb.SaveAs filename:=path & wksht.Range("A" & i).Value & ".xlsx"
wb.Close
Next i
End Sub
Try this:
Sub filename()
Dim i As Integer
For i = 1 To 32
ChDir "C:\path\"
ActiveWorkbook.SaveAs Filename:= _
"C:\path\" & Range("A" & i).Value & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Next i
End Sub
Note: Don't use "C:\" choose another folder. Probably you will need admin permissions to save there.
I want to create something that would loop through all the files from a directory with subfolders. Then, it would open each excel file and copy the total amount. The cell that contains the total is not always in a specific row, but column B of that row contains the text " TOTAL AMOUNT". The cell that contains the total is ALWAYS in column I. After it copies the cell, paste in the Master workbook ( the workbook the macro is running from ) in a new sheet in cell (i,2)
Cell(1,1) and Cell(1,2) are headers. "GROUPER" and "EFT_AMOUNT"
Here is what I have so far :
Sub PaymentFileMatching()
Dim HostFolder As String
Dim f As String, i As Long, arr, sht As Worksheet
Dim FSO As Object, objFolder As Object, FileInFolder As Object
Dim wb As Workbook, Masterwb As Workbook
Set sht = ActiveSheet
Set FSO = CreateObject("Scripting.filesystemobject")
Dim objSubFolder As Object
HostFolder = "C:\Users\kxc8574\Documents\Payment Files\Payment Files (Corrected)\PE20170701\"
Set objFolder = FSO.GetFolder(HostFolder)
Set Masterwb = Workbooks("Master Template")
Sheets("Sheet9").Activate
sht.Cells(1, 1).Resize(1, 2).Value = _
Array("GROUPER", "EFT_AMOUNT")
i = 2
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
sht.Cells(i, 1).Value = Left(FileInFolder.Name, InStr(FileInFolder.Name, "PE 2017") - 1)
Set wb = Workbooks.Open(objSubFolder & "\" & FileInFolder.Name)
For Each sht In Worksheets
For Each Cell In Sheets("Payment Summary").Range("B:B")
If Cell.Value = "Final EFT Payment Amount" Then
matchRow = Cell.Row
Cells(matchRow, 8).Copy
Workbooks("Master Template").Worksheets("Sheet9").Cells(i, 2).PasteSpecial xlPasteValues
i = i + 1
End If
Next Cell
Next FileInFolder
Next objSubFolder
End Sub
You arent defining what Cell is - put Option Explicit at the very top of your module and then try compiling and it will tell you the things you forgot to define. To define it use
Dim Cell as Range
Untested:
Sub PaymentFileMatching()
Const HostFolder As String = _
"C:\Users\kxc8574\Documents\Payment Files\Payment Files (Corrected)\PE20170701\"
Dim i As Long
Dim FSO As Object, objFolder As Object, FileInFolder As Object
Dim wb As Workbook, Masterwb As Workbook, MasterSht As Worksheet, sht As Worksheet
Dim objSubFolder As Object, f As Range, fName As String
Set FSO = CreateObject("Scripting.filesystemobject")
Set objFolder = FSO.GetFolder(HostFolder)
Set Masterwb = Workbooks("Master Template")
Set MasterSht = Masterwb.Sheets("Sheet9")
MasterSht.Activate
MasterSht.Cells(1, 1).Resize(1, 2).Value = Array("GROUPER", "EFT_AMOUNT")
i = 2
For Each objSubFolder In objFolder.subfolders
For Each FileInFolder In objSubFolder.Files
fName = FileInFolder.Name
MasterSht.Cells(i, 1).Value = Left(fName, InStr(fName, "PE 2017") - 1)
Set wb = Workbooks.Open(objSubFolder & "\" & fName)
For Each sht In wb.Worksheets
Set f = sht.Columns(2).Find("Final EFT Payment Amount", , xlValues, xlWhole)
If Not f Is Nothing Then
MasterSht.Cells(i, 2).Value = f.EntireRow.Cells(8).Value
i = i + 1
Exit For 'found the value...
End If
Set f = Nothing
Next sht
wb.Close False
Next FileInFolder
Next objSubFolder
End Sub
I have two questions but first a bit of background...
I have a number of workbooks each containing a different number of worksheets all saved in the same folder. Each worksheet except the first has an invoice from which I need data from specific cells copied on to the master sheet.
The Master sheet has 5 columns which will be populated with the information from the same 5 cells on each sheet on the following row.
Invoice Sheets Cell Master Sheet Row
E9 A
D18 B
D22 C
E11 D
F27 E
.
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim InvTotal As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long
Set destsheet = Workbooks("Test Master.xlsm").Worksheets("Sheet1")
'get list of all files in folder
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
'find first empty row in destination table
ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
'start at top of list of cell references and work down until empty cell reached
Application.Goto ThisWorkbook.Worksheets("Sheet1").Range("D16")
With ThisWorkbook.Worksheets("Sheet1")
Do While Not IsEmpty(.Cells(16, 4))
ColSrc = .Cells(9, 5)
RowSrcStart = .Cells(18, 4)
RowSrcEnd = .Cells(22, 4)
ColDest = .Cells(11, 5)
InvTotal = .Cells(27, 6)
RngSrc = ColSrc & RowSrcStart & ColSrc & RowSrcEnd & InvTotal
RngDest = ColDest & ResultRow
originsheet.Range(RngSrc).Copy
destsheet.Range(RngDest).PasteSpecial
Loop
End With
Workbooks(Fname).Close SaveChanges:=False 'close current file
Fname = Dir 'get next file
Loop
End Sub
So my first question is - how can I modify this code to make it paste the correct information in the correct cells...
Secondly - I've not yet attempted looping through each sheet in the workbooks as I'm not sure where to begin...
Any advice would be greatly appreciated
Untested:
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range
Set destsheet = ThisWorkbook.Worksheets("Sheet1")
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
If Fname <> ThisWorkbook.Name Then
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
With RngDest
.Cells(1).Value = originsheet.Range("E9").Value
.Cells(2).Value = originsheet.Range("D18").Value
.Cells(3).Value = originsheet.Range("D22").Value
.Cells(4).Value = originsheet.Range("E11").Value
.Cells(5).Value = originsheet.Range("F27").Value
End With
wkbkorigin.Close SaveChanges:=False 'close current file
Set RngDest = RngDest.Offset(1, 0)
End If
Fname = Dir() 'get next file
Loop
End Sub