Concatenate index name in the Workbooks Object - excel

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.

Related

How to find cell value in file names in a folder and open that file? File name contains more characters than cell value

This is the first week I learn vba so bear with me if I have a lot of questions;-)
So I have two folders, one folder contains the templates I need to update, the other contains the reports that the updates will be copied from. Cell A1 in each template contains the code that is specific to that BU. I need vba to find the code in the file names in the report folder and open that report. The problem is that the report names have different lengths, eg. it's named as XXX region_code_XXXXXXXXXXX, there can be any number of "X" before and after the code.
Sub Macro1()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder("C:\Users\35264\summary\test")
For Each file In ff.Files
Workbooks.Openfile
Set wbk2 = ActiveWorkbook
Sheets("Summary").Select
Range("A1").Select
rngX = Range("A1").Value
Now I need to find rngX in the file names in the report folder... I can't figure out how. Let me know if anyone can help! Thank you!
I am learning how to use dir function. I think it will be helpful to get the names of the reports first.
Combine the FileSystemObject Object With the Dir Function
Dir cannot be used in nested Do...Loops.
Using the FileSystemObject object, it opens files in one folder and uses the information in it to open specific files in another folder by using the Dir function. For each combination, it prints their names to the immediate window and closes each file without saving changes.
A better way to do this would be to write the file paths of the first folder to an array by using the Dir function and then loop through the elements of the array to open each file... etc.
Option Explicit
Sub PrintTemplatesAndReports()
' Templates
Const tFolderPath As String = "C:\Users\35264\summary\templates\"
Const tWorksheetName As String = "Summary"
Const rFilePatternAddress As String = "A1"
Const tFileExtensionLeft As String = "xls"
' Reports
Const rFolderPath As String = "C:\Users\35264\summary\reports\"
Const rFileExtensionPattern As String = ".xls*"
' 1st Worbook (ThisWorkbook)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(tFolderPath) Then Exit Sub
If Not fso.FolderExists(rFolderPath) Then Exit Sub
Dim fsoFolder As Object: Set fsoFolder = fso.Getfolder(tFolderPath)
' Templates (using the FileSystemObject object)
Dim fsoFile As Object
Dim twb As Workbook, tws As Worksheet
Dim tExtension As String, tFilePath As String
' Report (using Dir)
Dim rwb As Workbook
Dim rFilePattern As String, rFileName As String, rFilePath As String
' Counters
Dim ttCount As Long, tCount As Long, rCount As Long
For Each fsoFile In fsoFolder.Files
ttCount = ttCount + 1
tExtension = fso.GetExtensionName(fsoFile)
If InStr(1, tExtension, tFileExtensionLeft, vbTextCompare) = 1 Then
tCount = tCount + 1
tFilePath = tFolderPath & fsoFile.Name
' 2nd Workbook (Template)
Set twb = Workbooks.Open(tFilePath)
On Error Resume Next
Set tws = twb.Worksheets(tWorksheetName)
On Error GoTo 0
If Not tws Is Nothing Then
rFilePattern = CStr(tws.Range(rFilePatternAddress).Value)
rFileName = Dir(rFolderPath, "*" & rFilePattern _
& "*" & rFileExtensionPattern)
Do Until Len(rFileName) = 0
rCount = rCount + 1
rFilePath = rFolderPath & rFileName
' 3rd Workbook (Report)
Set rwb = Workbooks.Open(rFolderPath, rFileName)
' Do your thing, e.g.:
Debug.Print twb.Name, rwb.Name
rwb.Close SaveChanges:=False
rFileName = Dir ' next report
Loop
Set tws = Nothing
End If
twb.Close SaveChanges:=False
End If
Next fsoFile ' next template
MsgBox "Template files processed: " & tCount & "(" & ttCount & ")" _
& vbLf & "Report files processed: " & rCount & "(" & tCount & ")", _
vbInformation
End Sub

Excel File not Recognized by VBA

The error occurs on the Open.Workbooks MasterFile line. I get the error of "This file cannot be found. Has it been removed, renamed, or replaced?" I used the fso.FileExist function to make sure the file does actually exist, and when I debug.print, the file name is exactly as it is specified in the variable MasterFile. Why won't VBA recognize this .xlsm file?
Sub ProcessData()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim fil As Scripting.File
Dim MyDir As String
Dim FolderSource As Scripting.Folder
'FolderSource is the fso enabled directory folder
Dim FolderDataSource As Scripting.Folder
'FolderDest is the fso enabled folder where the MasterFile is located
MyDir = "C:\Users..."
'MyDir is where all part number files will be stored
Dim MasterFile As String
Dim MasterFilePath As String
MasterFilePath = "C:\Users..."
MasterFile = "Function Master File.xlsm"
Dim wbSource As Workbook, wsSource As Worksheet
'The workbook and worksheet source will be the Master FIle
Dim wbDest As Workbook, wsDest As Worksheet
'The destination workbook and worksheet corresponding to the part number file
Dim myArray As Variant
Dim myTable As ListObject
Dim x As Long
myArray = Range("D13:D17")
'Array will draw from part number values that are entered in the appropriate area on the template
'Creating files for all new part numbers
Set FolderSource = fso.GetFolder(MyDir)
'For Each fil In FolderSource.Files
For x = LBound(myArray) To UBound(myArray)
If myArray(x, 1) <> "" Then
PartNumFile = MyDir & "\" & myArray(x, 1) & ".xlsx"
If Not fso.FileExists(PartNumFile) Then
Set newbook = Workbooks.Add
With newbook
.SaveAs Filename:=PartNumFile
End With
End If
End If
'Searching for the Part Number Data in the Master File
Set FolderDataSource = fso.GetFolder(MasterFilePath)
For Each fil In FolderDataSource.Files
Debug.Print fil.Name
If fso.FileExists(MasterFilePath & "\" & MasterFile) Then
Debug.Print fil.Name
Workbooks.Open MasterFile
Set wbSource = Workbooks(MasterFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
Set wbDest = Workbooks(myArray(x, 1) & ".xlsx")
Set wsDest = wbDest.Worksheets(1)
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
wsSource.Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next
Next
End Sub

Insert Multiple Bitmap Image into Multiple Worksheet

In my folder, there is AA.bmp, AA.txt, BB.bmp and BB.txt
I am able to extract the data for AA.txt and BB.txt in a separate worksheet.
Am I also able to insert AA.bmp in the same sheet as AA.txt, and BB.bmp in the same sheet as BB.txt?
Sub ExtractData()
iPath = "C:\Users\NHWD78\Desktop\Report\Radiated Immunity\"
ifile = Dir(iPath & "*.txt")
Do While Len(ifile)
Sheets.Add , Sheets(Sheets.Count), , iPath & ifile
ifile = Dir
Range("A10:B10, A16:B19").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Application.CutCopyMode = False
Range("A6:K600").Clear
Columns.AutoFit
Loop
End Sub
I have search throughout the website but only found a way to insert a fixed image with image name.
This will answer your query, its more of a solution than an answer which is not what this site is for, but take the time to read through it as it should be educationally useful too.
You are trying to parse a folder that has content similar to below:-
The result os for these to be in an Excel workbook, with a worksheet containing the text and image for each group (AA, BB, and CC)
First step I would take is to use Microsoft Scripting Runtime, this makes parsing the folder a lot easier. To enable this, within the VBA environment (known as the IDE), select 'Tools' > 'References...', scroll down to 'Microsoft Scripting Runtime' and tick it, then click 'OK' to close the dialog box.
That allows us to the File System Object, which is a very useful file and folder manipulation and interrogation feature set.
Firstly we care most about the *.txt files so lets begin by looping through them:-
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")
'Then start a loop to look through each file in the folder
For Each Fl In Fldr.Files
'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
If Right(UCase(Fl.Name), 4) = ".TXT" Then
'We have found a file
End If
'Do events returns the processor to the system for any other items to be process
'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
DoEvents
Next
Set Fldr = Nothing
Next on the discovery of a text file we want to create a worksheet and import the text. For the sake of this example, it will all be done in a new workbook as well.
Dim WkBk As Workbook
Dim WkBk_Tmp As Workbook
Dim WkSht As Worksheet
Dim WkSht_Tmp As Worksheet
Dim StrName As String
'Create a new workbook
Set WkBk = Application.Workbooks.Add
'...
'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)
'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add
'Change the worksheet name to the file name
WkSht.Name = StrName
'Open the file in Excel
Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)
'Copy its contents into out worksheet
WkSht_Tmp.Cells.Copy WkSht.Cells
Set WkSht_Tmp = Nothing
'Close the file
WkBk_Tmp.Close 0
Set WkBk_Tmp = Nothing
Next we want to insert the image if it is there:-
Dim Rng As Range
'...
'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then
'This get the bottom row of data as a position to insert the image
Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)
'Add the picture
WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1
Set Rng = Nothing
End If
If we put all the above together it looks as below, hopefully this has been education in what is happening in the code, some good practices, how to approaching a task.
Option Explicit
Sub ExtractData()
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
Dim WkBk As Workbook
Dim WkBk_Tmp As Workbook
Dim WkSht As Worksheet
Dim WkSht_Tmp As Worksheet
Dim StrName As String
Dim Rng As Range
'Create a new workbook
Set WkBk = Application.Workbooks.Add
'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")
'Then start a loop to look through each file in the folder
For Each Fl In Fldr.Files
'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
If Right(UCase(Fl.Name), 4) = ".TXT" Then
'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)
'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add
'Change the worksheet name to the file name
WkSht.Name = StrName
'Open the file in Excel
Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)
'Copy its contents into out worksheet
WkSht_Tmp.Cells.Copy WkSht.Cells
Set WkSht_Tmp = Nothing
'Close the file
WkBk_Tmp.Close 0
Set WkBk_Tmp = Nothing
'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then
'This get the bottom row of data as a position to insert the image
Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)
'Add the picture
WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1
Set Rng = Nothing
End If
Set WkSht = Nothing
End If
'Do events returns the processor to the system for any other items to be process
'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
DoEvents
Next
Set Fldr = Nothing
Set WkBk = Nothing
MsgBox "Done!"
End Sub
Worksheet.Shapes.AddPicture will do it. Example below: -
Public Sub Sample()
Dim WkBk As Workbook
Dim WkSht As Worksheet
Dim Ole As Object
Set WkBk = ThisWorkbook
Set WkSht = WkBk.Worksheets(1)
WkSht.Shapes.AddPicture "C:\Users\garye\Desktop\AA.bmp", msoFalse, msoCTrue, 0, 0, -1, -1
Set WkSht = Nothing
Set WkBk = Nothing
End Sub

VBA - copy / paste one cell from multiple workseets to master sheet

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

Looping through sub-folders in a parent directory - vba

I am looking to copy/paste data from workbooks within different sub-folders within a user selected directory.
To explain: Basically, I want to automate a process whereby I perform a copy/paste ritual from many workbooks into one Summary Workbook (from which the code is initiated).
I have allowed user input to select the parent directory in which the subfolders are contained.
I have reached the stage where the looping occurs, but the data is not being copied and pasted.
Can anyone see flaw in my code or why it is not working?
Your help will be greatly appreciated.
Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim SubF As Scripting.Folder
Dim strFolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
strFolderName = .SelectedItems(1)
Else
MsgBox ("Selection Cancelled")
Exit Sub
End If
End With
Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder(strFolderName)
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub
Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WBc As Workbook
Dim shtWBc As Object
Set shtWBc = Sheets("QC Results")
Dim shtBatchwbk As Object
Dim lastrow As Long
Set shtBatchwbk = ThisWorkbook.Sheets("QC Results")
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row
For Each F In FF.Files
If (F.Name) Like "QC_results*" & ".xlsm" Then
Set WBc = Workbooks.Open(F)
' Copy QC results range into batch summary workbook
shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
WBc.Close SaveChanges:=False
Debug.Print F.Name
End If
Next F
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub
I believe your problem is here:
Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WBc As Workbook
Dim shtWBc As Object
Set shtWBc = Sheets("QC Results")
Dim shtBatchwbk As Object
Dim lastrow As Long
Set shtBatchwbk = ThisWorkbook.Sheets("QC Results")
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row
Notice that shtWBc and shtBatchwbk are most likely assigned to the exact same worksheet object.
shtBatchwbk is assigned from ThisWorkbook, and unless you have other workbooks open/active at the time, then shtWBc is assigned from the ActiveWorkbook, which would be the same workbook, thus the exact same worksheet.
The resolution would seem to be:
For Each F In FF.Files
If (F.Name) Like "QC_results*" & ".xlsm" Then
Set WBc = Workbooks.Open(F)
Set shtWBc = WBc.Sheets("QC Results") '##### ASSIGN THIS WORKSHEET FROM THE NEWLY OPNEED WORKBOOk
'Get the last row:
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row
' Copy QC results range into batch summary workbook
shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
WBc.Close SaveChanges:=False
Debug.Print F.Name
End If
Next F
Otherwise, revise your Q to provide more detail per Alexandre's comment.
UPDATE FROM COMMENTS
If you only need values, then this should be more reliable and faster than copy/paste.
Instead of:
shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
Do this:
shtBatchwbk.Range("A" & lastrow).Resize( _
shtWBc.Range("A4:SA11").Rows.Count, _
shtWBc.Range("A4:SA11").Columns.Count).Value = shtWBc.Range("A4:SA11").Value
And if you also want to copy formatting without doing the full "copy" because it sometimes changes/transposes numbers, etc., then you can add this as well:
shtWBc.Range("A4:SA11").Copy
shtBatchwbk.Range("A" & lastrow).PasteSpecial xlPasteFormats

Resources