Below is my code
Sub Append()
'Append data from other files
Path = "E:\NPM PahseIII\"
Filename = Dir(Path & "*.xlsx")
If InStr(Filename, ".") > 0 Then
Filenamenoext = Left(Filename, InStr(Filename, ".") - 1)
End If
MsgBox Filenamenoext
Range("A3").Select
Do While Filename <> ""
ActiveCell.Value = Filenamenoext
Loop
End Sub
My problem is that as I've selected Range("A3").Select is hard coded, i want this selection to be done dynamically in loop such that when the first iteration of the loop start it should select Range("A3").Select & further select next cell in the next iteration.
How can i achieve this?
Edited
See image below
Like this (untested):
Sub Append()
Const FPath As String = "E:\NPM PahseIII\"
Dim c As Range, Filename
'find the first empty cell in ColA
Set c = activesheet.cells(rows.count, 1).end(xlup).offset(1, 0)
Filename = Dir(FPath & "*.xlsx")
Do While Filename <> ""
c.Value = Split(Filename, ".")(0) 'note: problem if any of your file names have embedded periods...
Set c = c.offset(1, 0)
Filename = Dir()
Loop
End Sub
Related
Below code is used to run a macro that takes multiple variables and loops through the range to fill them into another sheet and then save as a pdf.
With 1 for each loop it works perfectly, but when I try to use 2; it will run through the first loop once and then loop through the second loop only.
Any ideas to fix this?
Sub CommandButton2_Click()
For Each c In Sheets("Resultaten").Range("N2:N1000").Cells '//Variable 1 range
If c = "" Then Exit For '//To end the loop when cells are empty
Sheets("Invuldocument").Range("B5").Value = c.Value '//Variable 1 transfer
For Each w In Sheets("Resultaten").Range("W2:W1000").Cells '//Variable 2 range
If w = "" Then Exit For '//To end the loop when cells are empty
Sheets("Invuldocument").Range("J5").Value = w.Value '//Variable 2 transfer
Application.Wait Now + #12:00:01 AM# ' //timer if the pc cannot handle the speed
Dim FileName As String '//Code below is to save as PDF in every loop
Dim Path As String
Application.DisplayAlerts = False
Path = "C:\Users\802435\Desktop\test12\"
FileName = "PRO-" & Range("B5").Value & "-" & Range("D41").Value & ".pdf"
ActiveWorkbook.SaveAs Path & FileName, xlOpenXMLWorkbook
Application.DisplayAlerts = True
Next '//Repeat for every Variable in the list until Exit For
Next '//No idea why i need this
End Sub
The idea is to loop through the row number then do a check if the value in both column N and W exist, if it does then it will copy the value to the 2 cells Invuldocument worksheet.
Sub CommandButton2_Click()
Const Path As String = "C:\Users\802435\Desktop\test12\" 'Assuming that the path don't change, you can declare it as a constant variable
Dim resultWS As Worksheet
Set resultWS = ActiveWorkbook.Worksheets("Resultaten")
Dim invulWS As Worksheet
Set invulWS = ActiveWorkbook.Worksheets("Invuldocument")
Dim i As Long
For i = 2 To 1000
If resultWS.Cells(i, "N").Value <> "" And resultWS.Cells(i, "W").Value <> "" Then
invulWS.Cells(5, "B").Value = resultWS.Cells(i, "N").Value
invulWS.Cells(5, "J").Value = resultWS.Cells(i, "W").Value
Dim FileName As String '//Code below is to save as PDF in every loop
Application.DisplayAlerts = False
FileName = "PRO-" & Range("B5").Value & "-" & Range("D41").Value & ".pdf"
ActiveWorkbook.SaveAs Path & FileName, xlOpenXMLWorkbook
Application.DisplayAlerts = True
Else
Exit For
End If
Next i
End Sub
Note: I did not test if the code for "saving as PDF" works as it is out of this question's scope. You are definitely encouraged to fully qualify your range reference in the code that assign FileName as it is currently referring to ActiveSheet which might not be what you want.
I've written a macro from parent file to change a child file.
The parent file has 10 + rows I want to cycle through.
The child file looks at row1 and creates a file based on the name in row 1.
I am then using a For and Next function to get the child to look at the next row and save the file based on the new name etc etc.
I get an error of:
Next without For
My code:
Sub CreateModels()
' set parameters
Dim vDestPath As String
Dim vDestFile As String
Dim vSrcePath As String
Dim vCurrFile As String
Dim vSrceFile As String
Dim vTot As Integer
vSrceFile = "Bridge 3-S Financial Model.xlsx"
vSrcePath = ActiveWorkbook.Path + "\Bridge 3-S Financial Model.xlsx"
vCurrFile = ActiveWorkbook.Name
vDestPath = ActiveWorkbook.Path & "\Output Models\"
'OpenFinancialModel
Workbooks.Open vSrcePath, UpdateLinks:=False
Sheets("Input Sheet Data").Select
Range("A4").Select
'creating models
For vTot = 6 To 1000
ActiveCell.FormulaR1C1 = "='[Input Sheet.xlsm]Input Sheet'!R" & vTot & "C1"
If Range("A4").Value <> 0 Then
Do
filepath = vDestPath & Range("a4") & ".Xlsx"
ActiveWorkbook.SaveAs (filepath)
vTot = vTot + 1
Next
Else
ActiveWorkbook.Close SaveChanges:=False
End If
End Sub
Remove the "Do" keyword and you might want to end the If statement before the "Next" keyword. Something like this:
For vtot = 6 To 1000
ActiveCell.FormulaR1C1 = "='[Input Sheet.xlsm]Input Sheet'!R" & vtot & "C1"
If Range("A4").Value <> 0 Then
filepath = vDestPath & Range("a4") & ".Xlsx"
ActiveWorkbook.SaveAs (filepath)
vtot = vtot + 1
Else
ActiveWorkbook.Close SaveChanges:=False
End If
Next
You need to improve your loops and queries. Half of the query If .. Then .. Else is within a For.. Next - not a good idea. Please check the position of Next and move to another place for your needs.
And there is an aborted Do missing some pseudo code like:
Dim k As Long
Do While k <= 10
Cells(k, 1).Value = k
Loop
Remove Do and debug your code.
I've a scenario in which i'm copying data from multiple files to master files, I want when the program run at first time it should start pasting the data at my specified range in the master file which is working fine. But when the program is run again it's not going to start from the previous range rather it's start pasting data below at the previous record which is duplication of the same data, I want that when user first time or as many time run the program program range start at the same location where it was at first time running.
Following is my code.
Sub Append()
'Append data from other files
Path = "E:\NPM PahseIII\"
Dim c As Range
'find the second empty cell in ColA
Set c = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
'target range for pasting data it first run this is actually pointing to
'my desire range but at second or multiple running the range is starting
'below at the previous record
Set targetcellL = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 1)
Set targetcellR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(5, 4)
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
If InStr(Filename, ".") > 0 Then
Filenamenoext = Left(Filename, InStr(Filename, ".") - 1)
End If
c.Value = Filenamenoext
Set c = c.Offset(4, 0)
Set wb = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
Data = wb.Worksheets(1).Range("B3:E6").Value
wb.Worksheets(1).Range("B3:E6").Copy
ThisWorkbook.Activate
ActiveSheet.Range(targetcellL, targetcellR).Select
ActiveSheet.Paste
Set targetcellL = targetcellL.Offset(4, 0)
Set targetcellR = targetcellR.Offset(5, 0)
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Problem: I want that when the program as run as many time it should start pasting Data it the Range where it is pasting data for the first time.
Following images will clear my problem more precisely.
When the program run for the first time i get pasted data it below range which is what i want.
When Run for the 2nd time i get data it below range
what should i do to make the behavior as such that when the program run for as many time the data should paste at the range where it's at first run see pic.
Here are two different ways to do it:
Sub AppendValuesAndFormats()
'Append data from other files
Const Path = "E:\NPM PahseIII\"
Dim target As Range
With ThisWorkbook.ActiveSheet
.UsedRange.Offset(2).ClearContents
Set target = .Range("A3")
End With
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
With Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
target.Value = IIf(InStr(Filename, ".") > 0, Left(Filename, InStr(Filename, ".") - 1), "")
.Worksheets(1).Range("B3:E6").Copy Destination:=target.Offset(0, 1)
.Close SaveChanges:=False
End With
Set target = target.Offset(4)
Filename = Dir()
Loop
End Sub
Sub AppendValues()
'Append data from other files
Const Path = "E:\NPM PahseIII\"
Dim target As Range
With ThisWorkbook.ActiveSheet
.UsedRange.Offset(2).ClearContents
Set target = .Range("A3")
End With
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
With Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
target.Value = IIf(InStr(Filename, ".") > 0, Left(Filename, InStr(Filename, ".") - 1), "")
target.Range("B1:E4").Value = .Worksheets(1).Range("B3:E6").Value
.Close SaveChanges:=False
End With
Set target = target.Offset(4)
Filename = Dir()
Loop
End Sub
I have an excel workbook with column [A] having numerous filenames. But only the name of the file, so without any extension. I would like to loop through each cell and check whether a file in a specific folder exist matching this string in the cell.
someone did not manage to find anything on Google.
thanks
This should do it.
Const dirPath As String = "C:\whateveryourPathIs\"
Sub RunIt()
Dim Rcell As Range
For Each Rcell In Intersect(Range("A:A"), ActiveSheet.UsedRange).Cells
If Not IsEmpty(Rcell) Then
If CheckIfFileExists(dirPath, Rcell.Value) Then
'whatever you want to happen when it finds a match
Debug.Print Rcell.Value & " was found"
End If
End If
Next Rcell
End Sub
Private Function CheckIfFileExists(srchDIR As String, MatchMember As String) As Boolean
Dim file As Variant, nameOfFile As String
If Right(srchDIR, 1) <> "\" Then srchDIR = srchDIR & "\"
file = Dir(srchDIR)
While (file <> "")
nameOfFile = Left(file, InStrRev(file, ".", -1, vbTextCompare) - 1)
If UCase(nameOfFile) = UCase(MatchMember) Then
CheckIfFileExists = True
Exit Function
End If
file = Dir
Wend
End Function
#PGCodeRider Thanks, I modified your code to my needs and it works now. anyone who is interested ("or also did not find anything on google") below the code:
Const dirPath As String = "C:\folderpath\..."
Sub RunIt()
Dim Rcell As Range
For Each Rcell In Intersect(Range("A:A"), ActiveSheet.UsedRange).Cells
If Not IsEmpty(Rcell) Then
If CheckIfFileExists(dirPath, Rcell.Value) Then
'whatever you want to happen when it finds a match
Debug.Print Rcell.Value & " was found"
End If
End If
Next Rcell
End Sub
Private Function CheckIfFileExists(srchDIR As String, MatchMember As String) As Boolean
Dim file As Variant
Dim length As Long
If Right(srchDIR, 1) <> "\" Then srchDIR = srchDIR & "\"
file = Dir(srchDIR)
While (file <> "")
length = Len(file)
For i = 1 To length
If Right(file, 1) <> "." Then
file = Left(file, length - 1)
length = Len(file)
Else
Exit For
End If
Next i
file = Left(file, length - 1)
'If InStr(1, file, MatchMember, vbTextCompare) > 0 Then
If file = MatchMember Then
CheckIfFileExists = True
Exit Function
End If
file = Dir
Wend
End Function
I have a set of Excel spreadsheets to summarise. My sheets are numbered:
xxx-yy-zzzz; xxx-yy-zzz+1; etc.
I would like a reporting spreadsheet to retrieve information each time it is opened. I don't mind doing it with VBA or with formulae.
I've the macro below. I need to auto increment until it runs out of spreadsheets. All the files will be in the same folder, this file can be in any folder.
Sub Macro1()
'
' Macro1 Macro
' autopop
'
'
Range("C4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R4C5"
Range("D4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R5C3"
Range("E4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Order'!R27C9"
Range("F4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R8C9"
End Sub
Siddharth's method above worked very well for when we were using very simple file names, but it got a lot harder when there were additions made to the filename... So i did some surfing and found a basis of a "list all files and put them in a worksheet" and using some of the code from Siddharth's answer above (thank you very much Mr. Siddharth) and the example i found online here http://alanmurray.blogspot.com/2013/08/excel-vba-list-all-excel-files-in-folder.html , i have finalised my code, and my little VBA app now does what i want - it opens a folder and goes through and pulls out particular cells and creates a summary report in seconds -> will save me hours of tedious work...
Code:
Sub ImportFileList()
Dim MyFolder As String 'Store the folder selected by the using
Dim FiletoList As String 'store the name of the file ready for listing
Dim NextRow As Long 'Store the row to write the filename to
On Error Resume Next
Application.ScreenUpdating = False
'Display the folder picker dialog box for user selection of directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
'Dir finds the first Excel workbook in the folder
FiletoList = Dir(MyFolder & "*.xls")
Range("A1").Value = "Filename"
Range("B1").Value = "Purchase Order Number"
Range("C1").Value = "Vendor"
Range("D1").Value = "Date of PO"
Range("E1").Value = "Currency"
Range("F1").Value = "Subtotal"
Range("G1").Value = "VAT"
Range("H1").Value = "Total"
Range("A1:H1").Font.Bold = True
'Find the next empty row in the list
NextRow = Application.CountA(Range("A:A")) + 1
NextRow = NextRow + 1 ' skip a line
'Do whilst the dir function returns an Excel workbook
Do While FiletoList <> ""
Cells(NextRow, 1).Value = FiletoList 'Write the filename into the next available cell
Cells(NextRow, 2).Formula = "='[" & FiletoList & "]Cover'!R4C4" ' Cover is the excel sheet name
Cells(NextRow, 3).Formula = "='[" & FiletoList & "]Cover'!R6C3"
Cells(NextRow, 4).Formula = "='[" & FiletoList & "]Cover'!R4C7"
Cells(NextRow, 5).Formula = "='[" & FiletoList & "]Cover'!R21C4"
Cells(NextRow, 6).Formula = "='[" & FiletoList & "]Cover'!R19C5"
Cells(NextRow, 7).Formula = "='[" & FiletoList & "]Cover'!R20C5"
Cells(NextRow, 8).Formula = "='[" & FiletoList & "]Cover'!R21C5"
NextRow = NextRow + 1 'Move to next row
FiletoList = Dir 'Dir returns the next Excel workbook in the folder
Loop
Application.ScreenUpdating = True
End Sub
Is this what you are trying? (UNTESTED)
'~~> Change this to the directory which has .xlsx files
Const sDir = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim i As Long, num As Long, Calcmode As Long
Dim FilesCount As Long, startNum As Long
On Error GoTo Whoa
Set ws = ThisWorkbook.Sheets("Sheet1")
With Application
.ScreenUpdating = False
Calcmode = .Calculation
.Calculation = xlCalculationManual
End With
'~~> Get the number of files in that directory
FilesCount = getFileCount(sDir)
startNum = 1
If FilesCount <> 0 Then
With ws
For i = 4 To (FilesCount + 3)
num = Format(startNum, "000")
.Range("C" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R4C5"
.Range("D" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R5C3"
.Range("E" & i).Formula = "='[413-05-" & num & ".xlsx]Order'!R27C9"
.Range("F" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R8C9"
startNum = startNum + 1
Next i
End With
End If
LetsContinue:
With Application
.ScreenUpdating = True
.Calculation = Calcmode
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Function getFileCount(s As String) As Long
Dim Path As String, Filename As String
Dim Count As Long
Path = s & "*.xlsx"
Filename = Dir(Path)
Do While Filename <> ""
Count = Count + 1
Filename = Dir()
Loop
getFileCount = Count
End Function