I'm a C# Programmer and new into Excel VBA and here I am on my limit.
I don't get the gist how to copy and paste data from different files into one Masterfile..
I want to collect all data from Excel Files in a userdefined folder. These data were always stored in excel files.
And always starts at the D column until last column from the 6th row to last row.
So I want first to get the Parent directory in which I get all the Files in this Parentfolder.
After that I start the CollectSubdataProcedure.
So my approach would be copy the range from each subfile and paste them into the 6th row and last column of my masterfile
Private Sub CollectData()
Dim MasterWorkbook As Workbook
Set MasterWorkbook = Workbooks("Masterfile.xlsm")
Dim Folderpath As String
'Get Folder which contains all Data
Folderpath = UserGetFolder & "\"
Dim obj As Object
Dim ParentFolder As Object
Dim Files As Object
Set obj = CreateObject("Scripting.FileSystemObject")
Set ParentFolder = obj.GetFolder(Folderpath)
Set Files = ParentFolder.Files
Application.ScreenUpdating = False
'Loop through all folder now
Dim subfile As Object
For Each subfile In ParentFolder.Files
'Start Data Collection
Call CollectSubdata(subfile)
Next subfile
End Sub
Here my Sub Procedure
Private Sub CollectSubdata(ByRef subfile As Object)
' Do Data collection here
Dim subwb As Workbook
Dim LastColumn As Double
Dim LastRow As Double
Dim LastMasterCol As Double
LastMasterCol = MasterWorkbook.Sheets(1).Cells(6, Columns.Count).End(xlToLeft).Column
Set subwb = Workbooks.Open(subfile)
LastColumn = subwb.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = subwb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Copy all necessary entries
subwb.Sheets(1).Range(Cells(6, 4), Cells(LastRow, LastColumn)).Copy
'Paste into Masterfile
MasterWorkbook.Sheets(1).Cells(6, LastMasterCol).PasteSpecial Paste:=xlPasteAll
subwb.Close
End Sub
And Here my Userdefined Folder
Function UserGetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
UserGetFolder = sItem
Set fldr = Nothing
End Function
I don't get the gist of VBA uses these objects and methods..
A variable only exists in the context in which it is defined. In your case the pointer masterworkbook is defined within the routine CollectData so it only exists within that routine. In order to get it into CollectSubData you either need to pass a reference to it as an argument to the subroutine, or define the variable at module level so that it exists for all routines within that module. The former is better practice, so you should define your CollectSubData as
Private Sub CollectSubdata(ByRef subfile As Object, ByRef MasterWorkbook As Workbook)
and call it as
'Start Data Collection
CollectSubdata(subfile,MasterWorkbook)
Note that Call is not needed in this context (although it's not wrong per se)
Related
Dears:
i have an issue with below code
as i need to Merge Two Files once importing them by filedialog then copy the result direclty to another workbook
the below cope is working but suddnly it copies only data of the first file which its file size is the bigger and i do not know why
Sub IIII_Import_BSS_Stock_All_Files()
Dim ws As Worksheet
Dim wb As Workbook
Dim Imported1wb As Workbook
Dim Imported1ws As Worksheet
Dim DialFirstFile As FileDialog
Dim Imported1FileName As String
Dim Imported1LastRow As Long
Dim Imported2wb As Workbook
Dim Imported2ws As Worksheet
Dim DialSecondFile As FileDialog
Dim Imported2FileName As String
Dim Imported2LastRow As Long
'FileName after using File Len for ordering the first file to be (available) and the second one to be (Maintain)
Dim FileLenNameSize1 As Long
Dim FileLenNameSize2 As Long
Dim TempFileOrder As String
Dim UpperArray() As String
Dim LowerArray() As String
Dim split_len As Long
Dim Imported1FileNameLnSpFn As String
Dim Imported2FileNameLnSpFn As String
Dim DestinationRange As Range
Dim ImportSelectARange As Range
Dim ImportSelectBRange As Range
Const SelectCols As String = "D:D,A:A,C:C,H:H,K:K,I:I"
Application.ScreenUpdating = False
Set DialFirstFile = Application.FileDialog(msoFileDialogFilePicker)
DialFirstFile.AllowMultiSelect = False
DialFirstFile.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
DialFirstFile.Show
Imported1FileName = DialFirstFile.SelectedItems.Item(1)
need.
If InStr(Imported1FileName, ".xls") = 0 Then
Exit Sub
End If
Set Imported1wb = Workbooks.Open(Imported1FileName)
Application.ScreenUpdating = False
Set DialSecondFile = Application.FileDialog(msoFileDialogFilePicker)
DialSecondFile.AllowMultiSelect = False
DialSecondFile.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
DialSecondFile.Show
Imported2FileName = DialSecondFile.SelectedItems.Item(1)
If InStr(Imported2FileName, ".xls") = 0 Then
Exit Sub
End If
Set Imported2wb = Workbooks.Open(Imported2FileName)
Set ws = ActiveSheet
FileLenNameSize1 = FileLen(Imported1FileName)
FileLenNameSize2 = FileLen(Imported2FileName)
If (FileLenNameSize1 < FileLenNameSize2) Then
TempFileOrder = Imported1FileName
Imported1FileName = Imported2FileName
Imported2FileName = TempFileOrder
End If
UpperArray = Split(Imported1FileName, "\")
LowerArray = Split(Imported2FileName, "\")
split_len = UBound(UpperArray) - LBound(UpperArray)
Imported1FileNameLnSpFn = UpperArray(split_len)
Imported2FileNameLnSpFn = LowerArray(split_len)
Set Imported1ws = Workbooks(Imported1FileNameLnSpFn).Worksheets("Default")
Set Imported2ws = Workbooks(Imported2FileNameLnSpFn).Worksheets("Default")
Imported1LastRow = Imported1ws.Cells(Imported1ws.Rows.Count, "A").End(xlUp).Offset(1).Row
Imported2LastRow = Imported2ws.Cells(Imported2ws.Rows.Count, "A").End(xlUp).Row
'Copy & Paste to the total stock sheet from the merged file
' but only Copy Selection of Non Adjacent Columns of the imported file not copying the entire sheet
Set Imported1ws = Workbooks(Imported1FileNameLnSpFn).Worksheets("Default")
'Selection of data in sheet 2 to be copied
Set ImportSelectARange = Intersect(Imported1ws.Range(SelectCols), Imported1ws.Rows("2:" & Imported1LastRow))
Set ImportSelectBRange = Intersect(Imported2ws.Range(SelectCols), Imported2ws.Rows("2:" & Imported2LastRow))
'Selection of last empy row at Sheet 1 to be copy data into it
'Copy from sheet 2 to sheet 1
Set Destination2FRange = ThisWorkbook.Worksheets("Total Stock").Range("A2")
Set Imported1ws = Workbooks(Imported1FileNameLnSpFn).Worksheets("Default")
Imported2ws.Range("A2:L" & Imported2LastRow).Copy Destination:=Imported1ws.Cells(Imported1LastRow + 1, "A")
'Copy from sheet 1 to sheet 2
Set Imported1ws = Workbooks(Imported1FileNameLnSpFn).Worksheets("Default")
Imported2ws.Range("A2:L" & Imported2LastRow).Copy Destination:=Imported1ws.Cells(Imported1LastRow + 1, "A")
ImportSelectARange.Copy _
Destination:=Destination2FRange
Workbooks(Imported1FileNameLnSpFn).Close
Workbooks(Imported2FileNameLnSpFn).Close
Please look at this part of your code.
UpperArray = Split(Imported1FileName, "\")
LowerArray = Split(Imported2FileName, "\")
split_len = UBound(UpperArray) - LBound(UpperArray)
Imported1FileNameLnSpFn = UpperArray(split_len)
Imported2FileNameLnSpFn = LowerArray(split_len)
The first 2 lines create 2 arrays. They would have the same number of elements if the two files were taken from the same directory, like "C:\User\MyFile.xls". But if one of the files is from a sub-directory it would have more elements, like "C:\User\MyFolder\MyFile.xls". The third line of code examines this difference and assigns it to the variable split_len. We therefore know that split_len may contain 0, a positive or negative low number.
In the next 2 lines this number is used to define an element of the arrays first created. The chance that this will be a file name are remote because the file name is in the last element of each array. This code would extract it.
Imported1FileNameLnSpFn = UpperArray(UBound(UpperArray))
Imported2FileNameLnSpFn = LowerArray(UBound(LowerArray))
The variable split_Len is ill-conceived and not useful as an array index. It can only be sheer coincidence that it does work on occasion. On principle, you may improve your code if you don't handle the two files parallel. Instead, develop a sub routine that handles one file at a time, call it twice with different files name or file objects as argument after determining which file to handle first.
I'm not sure that abandoning FileDialog is a good idea. In fact, if your two workbooks are in the same file location you could open them in one go by allowing multiple selection in the file open dialog box. In the code below the presumption is that the files are in different folders. Therefore I made a loop to call a function that returns one workbook at a time.
Option Explicit
Sub MergeFiles()
' 174
Dim Src(2) As Workbook ' sources
Dim Title As String
Dim FolderPath As String
Dim f As Integer ' Loop counter
' set the arguments for the first loop
Title = "Choose the first workbook to open"
' FolderPath can be a full file name (path & file name)
' or it can be just a folder name, ending on backslash
FolderPath = "D:\PVT Archive\Class 1\1-2021 (Jan 2023)\"
For f = 1 To 2
Set Src(f) = FileToOpen(Title, FolderPath)
If Src(f) Is Nothing Then Exit Sub ' user made no selection
' now set the arguments for the second loop
Title = "Choose the second workbook to open"
FolderPath = Environ("UserProfile") & "\Desktop\"
Next f
Debug.Print Src(1).Name
Debug.Print Src(2).Name
End Sub
Private Function FileToOpen(MyTitle As String, _
StartAt As String) As Workbook
' 174
' https://www.wallstreetmojo.com/vba-filedialog/
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Title = MyTitle
.AllowMultiSelect = False
.InitialFileName = StartAt
If .Show = -1 Then Set FileToOpen = Workbooks.Open(.SelectedItems(1))
End With
End Function
At the end of this code you have your two files. Comparing their size is not so easy. You probably need to find a function on the internet. Better use the InitialFileName in the above code to open the bigger file first, or find a way to differentiate them by their content.
I couldn't figure out from your code (I think I see only a part of it) what you want to do with the two files but whatever it is it starts where my above code ends and it would clearly exceed the scope of this thread. The above code puts your logic on a slightly different path but you can try to append your previous code to it and then ask a new question if you need more help.
I have a list of files with the same structure and I want to extract some information from columns A, B, and C and print it to another workbook.
I found a way to do it for a single file, but now I don't understand how can I do it using the list of given files. I tried using collections, but it doesn't work.
Here's what I came up with:
Sub Pulsante1_Click()
Dim FileGeStar As Variant
Dim myCol As Collection
Set myCol = New Collection
myCol.Add "C:\Users\xxx\Desktop\articoli_def.xlsx"
myCol.Add "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx"
For Each FileGeStar In myCol
Workbooks.Open Filename:=FileGeStar
FileGeStar = Application.ActiveWorkbook.Name
Dim Code As String
Dim Description As String
Dim FilePath As String
Dim i As Long
i = 2
While Range("A" & i) <> ""
FilePath = Application.ActiveWorkbook.Path
Code = Trim(Range("A" & i).Value)
Description = Trim(Range("B" & i).Value)
Workbooks("Report.xlsm").Worksheets(1).Range("A" & i).Value = FilePath
Workbooks("Report.xlsm").Worksheets(1).Range("B" & i).Value = Code
Workbooks("Report.xlsm").Worksheets(1).Range("C" & i).Value = Description
i = i + 1
Wend
Next FileGeStar
End Sub
What can I do?
This might look like an overkill, but I hope the code and comment's are self explanatory:
Option Explicit
Sub Pulsante1_Click()
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = ThisWorkbook 'I think report.xlsm is the workbook running the code
'if report.xlsm is not the workbook running the code then change thisworkbook for workbooks("Report.xlsm")
'add as many paths as you need to, another way would be to write them in a sheet and loop through to fill the array
Dim MyPaths As Variant
MyPaths = Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'Declare a workbook variable for the source workbooks
Dim SourceWorkbook As Workbook
'Declare a long variable to loop through your path's array
Dim i As Long
'loop through the start to the end of your array (will increase as the array does)
For i = LBound(MyPaths) To UBound(MyPaths)
Set SourceWorkbook = OpenWorkbook(MyPaths(i)) 'this will set the workbook variable and open it
CopyData SourceWorkbook, DestinationWorkbook 'this will copy the data to your destination workbook
SourceWorkbook.Close , False
Set SourceWorkbook = Nothing
Next i
End Sub
Private Function OpenWorkbook(FullPath As String) As Workbook
Set OpenWorkbook = Workbooks.Open(FullPath, False, True)
End Function
Private Sub CopyData(wbO As Workbook, wbD As Workbook)
'this procedure calculates the last row of your source workbook and loops through all it's data
'later calls the AddDataToMasterWorkbook procedure to paste the data
With wbO.Sheets(1) 'Im assuming your source workbook has the data on sheet1
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim FilePath As String
FilePath = wbO.Path
Dim Code As String
Dim Description As String
Dim C As Range
For Each C In .Range("A2:A" & LastRow) 'this will loop from A2 to the last row with data
Code = Trim(C)
Description = Trim(C.Offset(, 1))
AddDataToMasterWorkbook wbD, FilePath, Code, Description
Next C
End With
End Sub
Private Sub AddDataToMasterWorkbook(wb As Workbook, FilePath As String, Code As String, Description As String)
'This procedure calculates the last row without data and adds the items you need every time
With wb.Sheets(1)
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow) = FilePath
.Range("B" & LastRow) = Code
.Range("C" & LastRow) = Description
End With
End Sub
To loop though files, you can indeed use a collection, or an array, you can also loop through all files in directory with certain extension, or partial file name. Check out DIR function.
Best not to use ActiveWorkbook, better approach would be to set a workbook object like so: Set wb = Workbooks.Open(fullPathToYourWorkbook).
For what you're doing, there's no need to go row by row, much more efficient way would be to copy entire range, not only it's a lot quicker but also it's only 1 line of code; assuming your destination is ThisWorkbook.Sheets(1) and wb object is set: wb.Range("A:C").Copy Destination:=Thisworkbook.Sheets(1).Range("A:C"). If you need to edit copied data (trim or whatever) consider Range Replace method.
However, if you want to go row by row for whatever reason, as BigBen mentioned in the comment - get rid of While loop.
It's a good idea to set Application.ScreenUpdating to False when opening/closing workbooks, then back to True once it's all done. It will prevent user from accidentaly clicking something etc and will make it look like it's not opening any workbook.
Here's my approach (untested) assuming the workbook you want to copy data to is Workbooks("Report.xlsm").Worksheets(1):
Sub Pulsante1_Click()
'set workbook object for the destination workbook
set wb_dest = Workbooks("Report.xlsm").Worksheets(1)
'disable screen updating
Application.ScreenUpdating = False
For Each target_wb In Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'set wb object and open workbook
Set wb = Workbooks.Open(target_wb)
'find last row in this workbooks in columns A:B (whichever is greater)
LastRow = wb.Range("A:B").Find(What:="*", After:=wb.Range("A1"), SearchDirection:=xlPrevious).row
'copy required data
wb.Range("A1:B" & LastRow).Copy Destination:=wb_dest.Range("B1:C" & LastRow)
'fill column A with path to the file
wb_dest.Range("A1:A" & LastRow).Value = wb.Path
'close workbook
wb.Close False
Next
'enable screen updating
Application.ScreenUpdating = True
End Sub
Obviously an array is not the best approach if you have loads of different files, collection would be a lot clearer to read and edit in the future, unless you want to create a dynamic array, but there's no need for that in my opinion. I didn't declare variables or write any error handling, it's a simple code just to point you in the right direction.
If you want to disable workbook events or/and alerts, you can set Application.DisplayAlerts and Application.EnableEvents to False temporarily.
I have a user-form that pastes folder-paths into a list. I then have the code below that is supposed to loop through that list and list all the sub-folders (then I'll probably have another code loop through the sub-folders to get the excel workbooks).
I know it's inelegant, because ultimately what I want is have my list of paths be looked in one a time, through each folder and subfolder to find and list the excel files. But there was a question like that and it was taken down. The question was then referred to a different q&a that I did not understand, that had to do with individual FILE NAMES, typed in a single cell not a range, nor as a path. I speak Russian, which some of his code was in, and still couldn't quite understand what his code meant and was referring to, and when I tried it, it kept telling met that "GetData" was undefined? so I've tried to ask a different but similar question in the hope that someone can explain to me what I need to do, as I've gone as far as I can and have tried to adapt both codes from the links in this post as well as many others. I have several modules with broken code that doesn't work, and the closest I've come is the code below. At this point I'd settle simply for a way to list the excel file names from a list of paths.
Option Explicit
Dim i As Long, j As Long
Dim searchfolders As Variant
Dim FileSystemObject
Sub ListOfFolders77()
Dim LookInTheFolder As String
'Dim ws As Worksheet: Set ws = Sheets("Output4")
Dim ws2 As Worksheet: Set ws2 = Sheets("Output3")
Dim rng As Range: Set rng = ws2.Range("A1:A" & Rows.Count).End(xlUp)
Dim mypath As Range
'Dim Region As Range: Set Region = ws.Range("A2")
'Dim district As Range: Set district = ws.Range("B2")
'Dim city As Range: Set city = ws.Range("C2")
'Dim atlas As Range: Set atlas = ws.Range("D2")
i = 1
For Each mypath In rng
LookInTheFolder = mypath.Value
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
For Each searchfolders In FileSystemObject.GetFolder(LookInTheFolder).subfolders
Sheets("Subfolders").Cells(i, 1) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
Next mypath
End Sub
Sub SearchWithin(searchfolders)
On Error GoTo exits
For Each searchfolders In FileSystemObject.GetFolder(searchfolders).subfolders
j = UBound(Split(searchfolders, "\"))
Cells(i, j) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
exits:
End Sub
Ideally I want to get all the excel files in the folders and subfolders, and copy paste the data on the first sheet into one long list, but I'm still on step 1. I posted a more detailed explanation here last week and have yet to receive any feedback or potential tips.
I apologize if this doesn't make sense or seems half-hazard. I am self taught in excel VBA and am struggling to understand if what I need is even possible. I attempted using Directory but I've little success putting directory in a for each loop.
I also tried using an array, which almost crashed by computer as it went to list ALL the folders and files in my entire computer.
If I understand correctly, your requirements are as follows:
Begin with a set of root paths
Iterate recursively through all the files in each root path
For each file in the resulting collection, if it's an Excel file, add to final list for further processing
Let's start with the first two points. I would suggest the following code (make sure to add a reference to Microsoft Scripting Runtime via Tools -> References... in the VBA editor menus):
Public Function GetFiles(ByVal roots As Variant) As Collection
Select Case TypeName(roots)
Case "String", "Folder"
roots = Array(roots)
End Select
Dim results As New Collection
Dim fso As New Scripting.FileSystemObject
Dim root As Variant
For Each root In roots
AddFilesFromFolder fso.GetFolder(root), results
Next
Set GetFiles = results
End Function
Private Sub AddFilesFromFolder(folder As Scripting.folder, results As Collection)
Dim file As Scripting.file
For Each file In folder.Files
results.Add file
Next
Dim subfolder As Scripting.folder
For Each subfolder In folder.SubFolders
AddFilesFromFolder subfolder, results
Next
End Sub
The GetFiles function can be called by passing in a single string (or Folder):
Debug.Print GetFiles("c:\users\win8\documents").Count
or anything that can be iterated over with For Each -- an array, collection, Dictionary, or even an Excel Range object:
Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question
GetFiles as it stands is flexible for many use cases, and doesn't use any Excel-specific objects. In order to limit the results to Excel files only, you can create a new collection, and only add the Excel files into the new collection:
'You could filter by the File object's Type property
Sub GetExcelFilesByType()
Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question
Dim excelFiles As New Collection
Dim file As Scripting.File
For Each file In allFiles
If file.Type = "Microsoft Excel Worksheet" Then excelFiles.Add file
Next
End Sub
' Or you could filter by extension, using the FileSystemObject.GetExtensionName method
Sub GetExcelFilesByExtensionName()
Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question
Dim excelFiles As New Collection
Dim fso As New Scripting.FileSystemObject
Dim file As Scripting.File
For Each file In allFiles
Select Case fso.GetExtensionName(file.path)
Case "xls", "xlsb", "xlsm"
excelFiles.Add file
End Select
Next
End Sub
Either will get you a Collection of File objects, of only Excel files, from the set of root folders.
Notes
This code is recursively adding all the files (not just Excel files) into one collection (in GetFiles) and then filtering out the non-Excel files into a new collection. This might be less performant than adding only Excel files into the original collection, but that would limit GetFiles to only this scenario.
If you want to paste the results into an Excel worksheet, you could iterate through excelFiles and paste each path into the sheet. Alternatively, you might convert excelFiles into an array, and use the Excel Range object's Value property to set all the values from the array, without using a For Each.
References
Microsoft Scripting Runtime
FileSystemObject object, GetExtensionName method
File object
Folder object
VBA
Collection object
Here's a quick way, slightly adapted from this answer.
Just add in your folder locations to the path() = ... list and it should work for you. It outputs, in the current excel sheet, the paths of all Excel files in folders you provide.
From there, you can do what you please. (Perhaps throw the file paths in to an array, so you have an array of files you want to open. From there you can do the copying of data).
'Force the explicit delcaration of variables
Option Explicit
Sub ListFiles()
'http://www.xl-central.com/list-the-files-in-a-folder-and-subfolders.html
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
Dim path() As Variant ' EDIT THE BELOW PATH LIST FOR WHATEVER YOU NEED!
path() = Array("C:\Users\USERNAME\Desktop\Stuff\New folder", "C:\Users\USERNAME\Desktop\Other Stuff\")
'Insert the headers for Columns
Range("A1").Value = "File Name"
Range("D1").Value = "File Path"
Dim i As Long
For i = LBound(path) To UBound(path)
strTopFolderName = path(i)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
'Change the width of the columns to achieve the best fit
Columns.AutoFit
Next i
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long
'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files
Debug.Print (objFile)
If objFile.Type = "Microsoft Excel Worksheet" Then
Cells(NextRow, "A").Value = objFile.Name
Cells(NextRow, "D").Value = objFile.path
NextRow = NextRow + 1
End If
Next objFile
'Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
End Sub
I want to:
Copy the used range of a sheet called "Kommentar"
Create a ".txt" file ("Kommentar.txt") in the same directory as ThisWorkbook
Paste the previously copied used range
Save the ".txt" file
I have:
Sub CreateAfile()
Dim pth As String
pth = ThisWorkbook.path
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim a As Object
Set a = fs.CreateTextFile(pth & "\Kommentar.txt", True)
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Kommentar")
Dim rng As Range
Set rng = sh.UsedRange
a.WriteLine (rng)
a.Close
End Sub
I get
run-time error '13' Mismatch
In line a.WriteLine (rng) the function doesn't accept range to be written.
Since your range is probably made up of several cells, you have to loop through them to get all the text into a string variable. If you use a Variant variable you can copy the values and automatically get an array with the correct dimensions of all the data in the cells, then loop it and copy the text:
Function GetTextFromRangeText(ByVal poRange As Range) As String
Dim vRange As Variant
Dim sRet As String
Dim i As Integer
Dim j As Integer
If Not poRange Is Nothing Then
vRange = poRange
For i = LBound(vRange) To UBound(vRange)
For j = LBound(vRange, 2) To UBound(vRange, 2)
sRet = sRet & vRange(i, j)
Next j
sRet = sRet & vbCrLf
Next i
End If
GetTextFromRangeText = sRet
End Function
Call the function in your code by replacing the a.WriteLine (rng) line with the following:
Dim sRange As String
sRange = GetTextFromRangeText(rng)
Call a.WriteLine(sRange)
Not sure you can do that. I believe you would have to write it out line by line.
Here is an alternative option.
Rather than use the FSO, you could just try saving the sheet as a .txt file.
Here's some sample code.
Credit should goto http://goo.gl/mEHVx
Option Explicit
'Copy the contents of a worksheet, and save it as a new workbook as a .txt file
Sub Kommentar_Tab()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbDest As Workbook
Dim fName As String
'References
Set wbSource = ActiveWorkbook
Set wsSource = ThisWorkbook.Sheets("Kommentar")
Set wbDest = Workbooks.Add
'Copy range on original sheet
'Using usedrange can be risky and may return the wrong result.
wsSource.UsedRange.Copy
'Save in new workbook
wbDest.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'Get file name and location
fName = ThisWorkbook.Path & "\Kommentar.txt"
'Save new tab delimited file
wbDest.SaveAs fName, xlText
wbDest.Close SaveChanges:=True
End Sub
Let's say yourRange is the range you want to copy as string.
Use yourRange. Copy to copy it.
After you copied it, Excel saves the text value to the clipboard. Cells in a row separated by tabs, and every row ends with an enter. You can use DataObject's GetFromClipboard and GetText method to save it to a string variable.
Use CreateTextFile to save it to a file.
#xwhitelight gives a good outline. Thanks. But I needed to supply details to myself to accomplish my own task and thought I'd share.
First, a Reference to Microsoft Scripting Runtime and another to Microsoft Forms 2.0 Object Library are required.
The coding details I added to produce an output file follow.
Note that textfilename is the fully-qualified name of the output file that contains the spreadsheet range.
Note that textfilename is opened in the last line of the sub, which isn't necessary, but it's reassuring to SEE what the file contains. Of course, the MsgBox is also unnecessary.
Sub turnRangeIntoTextFile(rg As Range, textfilename As String)
Dim textFile as TextStream
Dim fs As FileSystemObject
Dim myData As DataObject
Set myData = New DataObject
Set fs = CreateObject("Scripting.FileSystemObject")
rg.Copy
myData.GetFromClipboard
MsgBox myData.GetText ' reassurance (see what I got)
Set textFile = fs.CreateTextFile(textfilename, True)
textFile.WriteLine (myData.GetText)
textFile.Close
CreateObject("Shell.Application").Open (textfilename)
End Sub
I need to grab a list of names from Excel and insert them into a Word document, printing one document per name. The document has some text and a bookmark called "name". The code is below.
First, I want to know if it's possible to detect how long is the list of names in the Excel spreadsheet and grab that, instead of hardcoding the number.
Second, I can't figure out how to delete the text I already put inside the document. When I insert text in a bookmark, it gets appended after the bookmark, so if I keep adding names they all stack together.
Maybe with the code this will be clearer:
Sub insertar_nombre()
Dim Excel As Excel.Application
Dim Planilla As Excel.Workbook
Dim Hoja As Excel.Worksheet
Set Excel = CreateObject("Excel.Application")
Dim Filename As String
Dim fname As Variant
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Seleccionar Documento de Excel"
.Show
For Each fname In .SelectedItems
Filename = fname
Next
End With
Set Planilla = Excel.Workbooks.Open(Filename)
Set Hoja = Planilla.Worksheets(1)
Dim Nombre As String
For Count = 2 To 10
Nombre = Hoja.Cells(Count, 1).Value
ActiveDocument.Bookmarks("name").Range.Text = Nombre
ActiveDocument.PrintOut
Next
End Sub
Forgive me if this code is obviously wrong or something, I'm just beginning with this.
I need to grab a list of names from Excel and insert them into a Word document, printing one document per name.
Why don't you simply use the mail merge feature?
the following Sub should solve this for you, but you might need to change the way your bookmark is defined.
There is more than one way to insert a Bookmark. This method requires the Bookmark to be inserted by highlighting the text, not simply positioning the cursor at a location in the text.
Sub insertar_nombre()
Dim xlWorkbook As Excel.Workbook
Dim xlWorksheet As Excel.Worksheet
Dim strFilename As String
Dim bkmName As Word.Range
Dim strBookmarkOriginalText As String
Dim lngRowLast As Long
Dim rngRowStart As Excel.Range
Dim rngRowEnd As Excel.Range
Dim rngNames As Excel.Range
Dim rngName As Excel.Range
'Open file dialog and only allow Excel files'
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Seleccionar Documento de Excel"
'Only let them select Excel files'
.Filters.Clear
.Filters.Add "Excel Documents (*.xls)", "*.xls"
'Check if a file is selected'
If .Show = True Then
'Since AllowMultiSelect is set to False, _
only one file can be selected'
strFilename = .SelectedItems(1)
Else
'No file selected, so exit the Sub'
Exit Sub
End If
End With
'Set the bookmark to a Word range (not a Bookmark object)'
Set bkmName = ActiveDocument.Bookmarks("name").Range
'Save the original text of the bookmark'
strBookmarkOriginalText = bkmName.Text
'Open the Excel file'
Set xlWorkbook = Excel.Workbooks.Open(strFilename)
Set xlWorksheet = xlWorkbook.Worksheets(1)
'Range of the first cell that contains a name'
Set rngRowStart = xlWorksheet.Cells(2, 1)
'Range of the last cell in the column'
lngRowLast = xlWorksheet.Range("A65536").End(xlUp).Row
Set rngRowEnd = xlWorksheet.Cells(lngRowLast, 1)
'Range of all cells from first name cell to last name cell'
Set rngNames = xlWorksheet.Range(rngRowStart, rngRowEnd)
'Loop through the range of names'
For Each rngName In rngNames
'Ignore any blank cells'
If rngName <> vbNullString Then
'Set the text of the bookmark range to the name from Excel'
bkmName.Text = rngName
'The above statement deleted the Bookmark, so create _
a new Bookmark using the range specified in bkmName'
ActiveDocument.Bookmarks.Add Name:="name", Range:=bkmName
'Print the document'
ActiveDocument.PrintOut
End If
Next
'Restore the orignal value of the bookmark'
bkmName.Text = strBookmarkOriginalText
ActiveDocument.Bookmarks.Add Name:="name", Range:=bkmName
'Close the Workbook without saving'
xlWorkbook.Close SaveChanges:=False
End Sub
Hope this helps.