Importing data from multiple text files into Excel VBA [closed] - vba

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I might have a question about VBA and Excel Macros. The thing that I need to do is to import data (actually integer values) from multiple text files that have random generated names (for example 12345678.txt, 8654321.txt, etc.) but which are stored in the same folder (let's call it Data folder) to excel into a column.
The problem that I face is that I have the same name for the measured values (called MVA) that are repeating over and over in the text files. I don't need all the data from the text files, only some specific rows of these MVA (for the example below let's say that I need only the MVA number for the "LED 01 Intensity" which is 6250 to be stored in a new cell in Excel. And I need to get that value that comes after "LED 01 Intensity" in the MVA row from 10 multiple text files (with random names that I don't know) to be stored each one in separate cells in Excel (from A1 to A10).
Example_____________________________________________________________________
Name: 153588.txt
Date: 14.05.2016
Name of product: Electronic Device 01
CHECK TEST
Resistance 101
MVA: 2 Ohm
MAX: 5 Ohm
MIN: 0 Ohm
PASS
LED 01 Intensity
MVA: 6250
MAX: 10000
MIN: 5000
PASS
I need a lot of these MVA values to be stored in Excel for analysis and I need to get an idea if this problem can be solved with VBA. If you can offer me some help to create a macro for this I would be thankful (I have basic knowledge of programming but I'm a beginner in VBA).

Here is the code I promised for. It is actually not only sample but actual code that you need according the descriptions you provided.
Please note I wrote it according to the sample file you provided - means that it might fail with different text file structures.
You will notice there is a settings section at the beginning. That's where you setup what needs to be given to the code.
It won't be a big impact for only hundreds of text files for your system considering the sample file - perhaps will work and finish in seconds. However screen updating might be disabled in the code during the code execution. See ScreenUpdating property of Excel Application object if you notice a real big system slowness.
I am hoping to give you some good start for the VBA, so I tried to use many methods and commented a lot to explain what we are doing in each step. For example, using the first worksheet as results worksheet in the newly created workbook but creating a new worksheet for the temporary worksheet. There is a reason for this: every new workbook is created with at least one worksheet but it might be also the only one worksheet according to the Excel settings in that computer. However, even those part could be designed different by getting the number of the worksheets first and delete the unnecessary ones and keep only 2 then use those instead creating a new one.
Shortly - there are many different ways to accomplish the same task - like in many other programming languages. For example, I used QueryTable to import data into the worksheet then used Find method to find out if it has the values I needed. I didn't have to do this, I could have instead put the all information in a string variable and make the search in the string! Or by using another method, or another.
Finally this is supposed to be what you need. And I hope it gives you a good start. To make this code work: Create a new workbook -> goto VBA -> Use menu and Insert->Module -> Copy and paste the following code into the right pane opened in the editor. Change the necessary variables in the settings area at the beginning in the sub procedure (likely only the path variable) and hit F5 to run the code.
Sub ImportData()
Dim wrk As Workbook
Dim shtSource As Worksheet
Dim shtResult As Worksheet
Dim rng As Range
Dim fndSection As Range
Dim fndValue As Range
Dim data As QueryTable
Dim strFile
Dim strPath As String
Dim strExt As String
Dim strSection As String
Dim strValue As String
' ======== BEGIN SETTINGS ========
' Define the files path - note there is a last backslash
strPath = "C:\Users\smozgur\Desktop\files\"
' Define file extension
strExt = "*.txt"
' Section to be find
strSection = "Led 01 Intensity"
' Cell value to be find after section
strValue = "MVA:"
' ======== END SETTINGS ========
' Create a new workbook to not mess with existing
Set wrk = Application.Workbooks.Add
With wrk
' Use first (or only) worksheet to store results
Set shtResult = .Worksheets(1)
' Create temp worksheet for reading text files
Set shtSource = .Worksheets.Add
End With
' Name the Results worksheet
' and put search value to indicate it in results
With shtResult
.Cells(1, 1).Value = strValue
.name = "Results"
End With
' Make file search with the given path & extension information
strFile = Dir(strPath & strExt, vbNormal)
' Dir function returns the first file name
' with the given extension in the given path
' if it is empty string then it means "no more file returned"
Do Until strFile = ""
' Create a query table buffer by using the file reference
' in the temp worksheet starting from cell A1
Set data = shtSource.QueryTables.Add(Connection:="TEXT;" & strPath & strFile, Destination:=shtSource.Cells(1, 1))
' Set up query table import properties
With data
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
' Finally retrieve data from the file
.Refresh BackgroundQuery:=False
End With
' Now the file content is in the temp worksheet as rows
' Find the section string in the data as Cell
Set fndSection = data.ResultRange.Find(strSection)
If Not fndSection Is Nothing Then
' If section is found then search for the Value Name AFTER found section
Set fndValue = data.ResultRange.Find(strValue, fndSection)
If Not fndValue Is Nothing Then
' If Value Name is found then put it into the next available cell in Results worksheet
' by removing the Value Name, so it will be the value itself
shtResult.Cells(shtResult.Rows.Count, 1).End(xlUp).Offset(1).Value = Replace(fndValue, strValue, "")
End If
End If
With data
' Clear the query table range
.ResultRange.Delete
' Delete the query table so we can recreate it for the next file
.Delete
End With
' Search for the next file meets the given path and extension criteria
strFile = Dir
Loop
' Delete the temporary worksheet
' Make it silent disabling Application Alerts about deleting the worksheet
Application.DisplayAlerts = False
shtSource.Delete
' Enable Application Alerts back
Application.DisplayAlerts = True
End Sub
Enjoy VBA programming!
==================================
* EDIT FOR MULTIPLE SECTIONS *
Following code handles multiple sections in the source files.
Sub ImportData()
Dim wrk As Workbook
Dim shtSource As Worksheet
Dim shtResult As Worksheet
Dim rng As Range
Dim fndSection As Range
Dim fndNextSection As Range
Dim fndValue As Range
Dim data As QueryTable
Dim strFile
Dim strPath As String
Dim strExt As String
Dim strSection As String
Dim strSections
Dim strValue As String
Dim i As Integer
Dim indFileNames As Boolean
' ======== BEGIN SETTINGS ========
' Define the files path - note there is a last backslash
strPath = "C:\Users\smozgur\Desktop\files\"
' Define file extension
strExt = "*.txt"
' Sections to be find
strSections = Array("Led 01 Intensity", _
"Led 02 Intensity", _
"Led 03 Intensity", _
"Led 04 Intensity", _
"Led 05 Intensity")
' Cell value to be find after section
strValue = "MVA:"
' Indicate file names in the output?
indFileNames = True
' ======== END SETTINGS ========
' Create a new workbook to not mess with existing
Set wrk = Application.Workbooks.Add
With wrk
' Use first (or only) worksheet to store results
Set shtResult = .Worksheets(1)
' Create temp worksheet for reading text files
Set shtSource = .Worksheets.Add
End With
' Name the Results worksheet
' and put section headers to indicate their columns
With shtResult
With .Cells(1).Resize(, UBound(strSections) + 1)
.Value = strSections
.Resize(, UBound(strSections) + 1).Font.Bold = True
End With
If indFileNames = True Then
With .Cells(1, UBound(strSections) + 3)
.Value = "NOTES"
.Font.Bold = True
End With
End If
.name = "Results"
End With
' Make file search with given information
strFile = Dir(strPath & strExt, vbNormal)
' Dir function returns the first file name
' with the given extension in the given path
' if it is empty string then it means "no more file returned"
Do Until strFile = ""
' Create a query table buffer by using the file reference
' in the temp worksheet starting from cell A1
Set data = shtSource.QueryTables.Add(Connection:="TEXT;" & strPath & strFile, Destination:=shtSource.Cells(1, 1))
' Set up query table import properties
With data
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
' Finally retrieve data from the file
.Refresh BackgroundQuery:=False
End With
' Now the file content is in the temp worksheet as rows
' Loop through requested sections
For i = 0 To UBound(strSections)
' Find the section string in the data as Cell
Set fndSection = data.ResultRange.Find(strSections(i))
If Not fndSection Is Nothing Then
' If section is found then search for the Value Name AFTER found section
Set fndValue = data.ResultRange.Find(strValue, fndSection)
If Not fndValue Is Nothing Then
' What if value doesn't exist in this section but it finds the next value in the next section
' We have to avoid that unless we are certainly sure each section MUST have the value
If i < UBound(strSections) Then
Set fndNextSection = data.ResultRange.Find(strSections(i + 1), fndSection)
Else
Set fndNextSection = shtSource.Cells(shtSource.Rows.Count)
End If
' Next available cell in the Results worksheet
Set rng = shtResult.Cells(shtResult.Rows.Count, i + 1).End(xlUp).Offset(1)
' Only use the value if found value belongs to the section
If fndValue.Row < fndNextSection.Row Then
' If Value Name is found then put it into the next available cell in Results worksheet
' by removing the Value Name, so it will be the value itself
rng.Value = Replace(fndValue, strValue, "")
Else
rng.Value = "N/A"
End If
End If
End If
Next i
If indFileNames = True Then
' Let's indicate which file we got this values
Set rng = shtResult.Cells(shtResult.Rows.Count, UBound(strSections) + 3).End(xlUp).Offset(1)
rng.Value = strFile
End If
With data
' Clear the query table range
.ResultRange.Delete
' Delete the query table so we can recreate it for the next file
.Delete
End With
' Search for the next file meets the given path and extension criteria
strFile = Dir
Loop
' Autofit columns in the Results worksheet
shtResult.Columns.AutoFit
' Delete the temporary worksheet
' Make it silent disabling Application Alerts about deleting the worksheet
Application.DisplayAlerts = False
shtSource.Delete
' Enable Application Alerts back
Application.DisplayAlerts = True
End Sub

Related

Code slow down as report grows

I have been running this code in my day to day work to keep on top of my orders and shipping, the code opens a spreadsheet in a specified location and returns the following, invoice number, company name, shipping date and total order value and puts them into one main spreadsheet.
I started using it last year and it used to take just under 3 minutes to run through about 400-500 spread sheets to collect the data. now I have a similar amount of data to run through this year but the report takes hours!!
I haven't changed my report and the data is the same data from the same template just in a different folder but in the same location on the same drive under the same parent folder.
I don't think it s the change of location that has slowed it down.
I have included a copy of my code below with notes under most of the code to explain the function of each line, can anyone see any problems with the code or recommend any improvements?
Sub Invoice_Records()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim FileExt As String
Dim CellValue As Range
Dim Text As String
Dim Text2 As String
Dim Text3 As String
Dim Total As Range
Dim filecountB As String
Dim i As String
Dim ws As Worksheet
Dim Invoice_Count As Integer
Set ws = Worksheets("Admin2")
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns(2).EntireColumn.Clear
ws.Columns(3).EntireColumn.Clear
ws.Columns(4).EntireColumn.Clear
ws.Columns(5).EntireColumn.Clear
ws.Columns(6).EntireColumn.Clear
ws.Columns(7).EntireColumn.Clear
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
filecountB = objFolder.Files.Count
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
ws.Cells(i + 1, 2) = objFile.Name
'print file path
ws.Cells(i + 1, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Path
'Get the file extension
FileExt = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, "."))
'Paste file extension in column D
ws.Cells(i + 1, 4) = FileExt
If FileExt = "xlsm" Then
'This line stops the excel documents opening on your screen they just open in the background meaning your screen does not flicker
Application.ScreenUpdating = False
Application.StatusBar = True
Application.StatusBar = "Currently processing item " + i + " out of " + filecountB
'This opens the documents
Workbooks.Open Filename:=objFile.Path
'Tells VBA what you are looking for
Text = "Total Invoice Value"
'Find text, defined in line above
Set Match = ActiveSheet.Cells.Find(Text)
'Get the value of the cell next to cell found above
findoffset = Match.Offset(, 1).Value
'Paste this value in to column F
ws.Cells(i + 1, 6) = findoffset
'Tells VBA what else to look for
Text2 = "Order No:"
'Find Text2, defined in line above
Set Index = ActiveSheet.Cells.Find(Text2)
'If "Order No:" cant be found then do below if it is found skip to ELSE
If Index Is Nothing Then
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
Else
'Paste the "Order No:" in column G
ws.Cells(i + 1, 7) = Index
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
End If
Else
'If file extension is anything other than XLSM then leave the date blank
ws.Cells(i + 1, 5) = ""
'Go onto the next file
i = i + 1
End If
Next objFile
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
Application.StatusBar = False
Call FindingLastRow
End Sub
Sub FindingLastRow()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Set ws = Worksheets("Admin2")
'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "A")
'returns the cell A1048576, ie. last cell in column A, and the code starts from this cell moving upwards;
'the code is bascially executing Range("A1048576").End(xlUp), and Range("A1048576").End(xlUp).Row finally returns the last row number.
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
ws.Range("Row_Number").Value = lastRow
End Sub
Alright, so I changed a few things and removed some unnecessary code. Here is my "changelog":
Commented out call to FindingLastRow as it currently does nothing
Moved the 'Dims' around so that they are easier to read
Removed unused variables
Added variables for the temporary workbooks
I did this to avoid using ActiveSheet which will slow code down
NOTE: The line that sets wsTemp might not work correctly, let me know if it fails
Grouped the columns.clear calls you made
Changed starting value of i to 2 for simplicity
Added range variables to catch the Range.Find("..") results
Moved Application.ScreenUpdating call outside of loop
No reason to have it toggle so frequently inside of the loop itself
Added toggle to .Calculation and .EnableEvents to potentially speed program up further
They act similarly to .ScreenUpdating by suppressing excel and speed up by focusing on only certain operations
Removed the .select for the hyperlinks
Like calling Activesheet, calling .select will also slow code down
String concatenation for StatusBar uses & instead of +
Changed around how the if statements were used to clear out duplicate code
A couple times you were repeating code in the ifs when you can just do it right after them
Re-ordered the value pasting to match the columns theyre pasted in (ie C,D,E,F,G )
When calling cells using .cells(r,c) you can actually just use the column string, so I did that for simplicity
NOTE: your comments said that 'Date' would go in column F but your actual code put it in column E, so I chose to use E
Started using .value2 and .value when accessing/pasting text into cells
NOTE: added offset to the "order no" to match your other searches (it looked like an oversight)
I think that's it???
With all that in mind, here is the result. Hopefully it scales properly with your folder now :)
Sub Invoice_Records()
Dim ws As Worksheet
Set ws = Worksheets("Admin2")
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
'Create an instance of the FileSystemObject
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Dim objFolder As Object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
Dim objFile As Object
Dim i As Long
i = 2
Dim FileExtension As String
Dim filecountB As String
filecountB = objFolder.Files.count
Dim searchInvValue As Range
Dim searchOrderNum As Range
Dim searchDate As Range
'Toggling screen updating prevents screen flicker and speeds up operations
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.StatusBar = True
End With
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns("B:G").EntireColumn.Clear
'Loops through each file in the directory
For Each objFile In objFolder.Files
'Update status bar to show progress
Application.StatusBar = "Currently processing item " & (i - 1) & " out of " & filecountB
'Paste file name
ws.Cells(i, "B").Value2 = objFile.Name
'Paste file path and add a hyperlink to it
ws.Hyperlinks.Add Anchor:=ws.Cells(i, "C"), Address:=objFile.path, TextToDisplay:=objFile.path
'Get the file extension
FileExtension = UCase$(Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")))
'Paste file extension
ws.Cells(i, "D").Value2 = FileExtension
'Only do operations on files with the extension "xlsm", otherwise skip
If FileExtension = "xlsm" Then
'This opens the current "objFile" document
Set wbTemp = Workbooks.Open(Filename:=objFile.path)
Set wsTemp = wbTemp.Sheets(1)
'Find and paste "Date:"
Set searchDate = wsTemp.Cells.Find("Date:")
ws.Cells(i, "E").value = searchDate.Offset(, 1).value
'Find and paste "Total Invoice Value"
Set searchInvValue = wsTemp.Cells.Find("Total Invoice Value")
ws.Cells(i, "F").Value2 = searchInvValue.Offset(, 1).Value2
'Find "Order No:" and paste if not blank
Set searchOrderNum = wsTemp.Cells.Find("Order No:")
If Not searchOrderNum Is Nothing Then ws.Cells(i, "G").Value2 = searchOrderNum.Offset(, 1).Value2
'Close the current "objFile" workbook
wbTemp.Close
End If
'Go onto the next file
i = i + 1
Next objFile
'Turn screen updating back on so that you can see the values being updated
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.StatusBar = False
End With
'Call FindingLastRow 'this does not currently seem necessary
End Sub

how to move down 1 row for every loop until cell empty

How do I move down 1 row for every loop until cell empty in column A?
I need to start on Row 5 copy to another workbook then loop to the next row (Row6) until contents are empty.
Here is my code
Sub Macro3()
'''
Do
''GRAB A ROW
Windows("theFILE2.working.xlsm").Activate
Rows("5:5").Select
Selection.Copy
Workbooks.Open "D:\folder1\folder2\Projects\The FILES\New folder\OVERVIEW TEMPLATE(macro edition)(current).xlsm"
Windows("OVERVIEW TEMPLATE(macro edition)(current).xlsm").Activate
Sheets("LISTS").Select
Rows("4:4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Windows("OVERVIEW TEMPLATE(macro edition)(current).xlsm").Activate
Sheets("PLANT OVERVIEW").Select
''SAVE AS
Dim Path As String
Dim FileName1 As String
Dim FileName2 As String
FileName1 = Range("N1").Value
FileName2 = Range("A1").Value
Path = "D:\folder1\folder2\Projects\The FILES\theFILES\" & FileName1 & "\"
ActiveWorkbook.SaveAs Filename:=Path & FileName2 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close
Loop
End Sub
Thankyou in advanced!
I see you're new to VBA, and there are some concepts you're picking up pretty quickly. Recording macros in Excel is a great way to find out how you could do something in Excel. However, there are some drawbacks to the way Excel does it also. Here are a few concepts that will help:
Don't use Selection, ActiveCell, ActiveSheet, Select, Activate, etc. unless you absolutely have to. I know that's what the Macro Recorder in Excel does, but if you don't do it exactly right, it can cause errors, especially when you start working with multiple workbooks!
Much better to assign an object, and use that object to do what you want to do. In the code below, I assigned the Workbooks and worksheets to objects and used those to get stuff done. Ranges are also common objects to use.
Related to that, make sure to always fully qualify your objects. For example, you can write code like this: Var1 = Cells(1, 1).Value but it will get the value from cell A1 in the Active Worksheet, not necesarily the worksheet or workbook you intended. Much better to write it this way: Var1 = wksSource.Cells(1, 1).Value I did specify a sheet name "Sheet1" for your source workbook - change it to the actual name of the sheet you're copying from.
I assigned the most common strings to Constants at the top. There's a balance between assigning every string to a constant and using only in-line strings (for example, some might assign the sheet names like "LISTS" to a constant), but if they're only used once and in a prominent place, I don't worry about assigning a constant for it. But especially when the value is used multiple places, a constant makes it easier for when you want to re-use the code for a similar task. I also put a constant in there for the Source Path, although that's not required if the workbook is already open.
I also declared all the variables at the top - some languages and programmers do it differently, but I like to be able to see what's being used at the beginning.
Notice the While specifier on your Do ... Loop. This will only loop while there is a value in the first column of the current row.
Here's how I would write the code for your task:
Sub Macro3()
Dim SourceRow As Long
Dim DestRow As Long
Dim Path As String
Dim FileName1 As String
Dim FileName2 As String
Dim FullFileName As String
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wksDest2 As Worksheet
Const scWkbSourcePath As String = "D:\folder1\folder2\Projects\" ' For example
Const scWkbSourceName As String = "theFILE2.working.xlsm"
Const scWkbDest1Path As String = "D:\folder1\folder2\Projects\The_FILES\New_folder\"
Const scWkbDest1Name As String = "OVERVIEW TEMPLATE_macro edition_current_.xlsm"
Const scWkbDest2Path As String = "D:\folder1\folder2\Projects\The_FILES\theFILES\"
Set wkbSource = Workbooks(scWkbSourceName)
Set wksSource = wkbSource.Sheets("Sheet1") ' Replace Sheet1 with the sheet name
SourceRow = 5
DestRow = 4
Do While wksSource.Cells(SourceRow, 1).Value <> ""
' Open the template workbook
Set wkbDest = Workbooks.Open(scWkbSourcePath & scWkbDest1Name)
Set wksDest = wkbDest.Sheets("LISTS")
''COPY A ROW
wksSource.Rows(SourceRow).Copy Destination:=wksDest.Rows(DestRow)
Application.CutCopyMode = False
With wksDest.Rows(DestRow).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
wkbDest.Activate
Set wksDest2 = wkbDest.Sheets("PLANT OVERVIEW")
''SAVE AS
FileName1 = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
Replace(wksDest2.Range("N1").Value _
, ".", "_") _
, "/", "_") _
, "\", "_") _
, "?", "_") _
, "|", "_") _
, "<", "_") _
, ">", "_") _
, ":", "_") _
, "*", "_") _
, """", "_")
FileName2 = wksDest2.Range("A1").Value
Path = scWkbDest2Path & FileName1 & "\"
If Len(Dir(Path, vbDirectory)) = 0 Then
MkDir Path
End If
FullFileName = Path & FileName2 & ".xlsx"
wkbDest.SaveAs Filename:=FullFileName, FileFormat:=xlOpenXMLWorkbook
wkbDest.Close
' Best practice to set objects to Nothing before re-using an object variable
Set wksDest = Nothing
Set wksDest2 = Nothing
Set wkbDest = Nothing
' Move down 1 row for source sheet
SourceRow = SourceRow + 1
Loop
End Sub
Edit
Some notes and things I learned regarding Folder and File name characters:
Although parentheses can be used in filenames, I wasn't able to get your original filename to save - but removing the parentheses solved the problem.
Since you're creating file and folder names from (potentially dirty) data, you should clean up (remove or replace with _) the characters that can't be used in those names: \ / | ? < > : * "
I found this on a Microsoft page for Naming Files, Paths, and Namespaces:
Do not end a file or directory name with a space or a period.
Although it is allowed inside a file name, a full stop (.) cannot be the last char of a folder name, which is generally where you find it in a text string. Besides, it can be confusing and occasionally cause problems within a file name, so I'd recommend replacing them all.
The Trim() function can be used to remove spaces at the end of a folder name. Be aware that within the string, it also changes multiple spaces in a row to a single space.
Especially since you're creating folders from data, you need to make sure the folder exists before saving a file to it. MkDir is the command for this.
If your template workbook isn't open when you start, you may need to specify the path as well in the Open() statement.

Excel 2010 - Tabs created, now need to copy from external source

I was forced to start to learn this by my employer. Unfortunately I was not given much time to prepare and I need to give results soon :-)
Here is something I was able to put together with assist of this forum - it's creating tabs for each day and naming them properly:
Sub Testovanie()
'
' Testovanie Macro
'
' Keyboard Shortcut: Ctrl+a
'
Dim pocet_tabov As Integer
Dim netusim As Integer
Dim sheet_meno As String
Dim string_pre_datum As String
Dim zadany_mesiac As Integer
Dim datum As Date
zadany_mesiac = 13
While (zadany_mesiac < 1) Or (zadany_mesiac > 12)
zadany_mesiac = Val(InputBox("Numeric month?"))
If zadany_mesiac = 0 Then Exit Sub
Wend
Application.ScreenUpdating = False
string_pre_datum = Str(zadany_mesiac) & "/1/" & Year(Now())
datum = CDate(string_pre_datum)
For pocet_tabov = 1 To 10
sheet_meno = Format((datum + pocet_tabov - 1), "dd.MMM.yyyy")
If Month(datum + pocet_tabov - 1) = zadany_mesiac Then
If pocet_tabov <= Sheets.Count Then
If Left(Sheets(pocet_tabov).Name, 5) = "Sheet" Then
Sheets(pocet_tabov).Name = sheet_meno
Else
Sheets.Add.Move after:=Sheets(Sheets.Count)
ActiveSheet.Name = sheet_meno
End If
Else
Sheets.Add.Move after:=Sheets(Sheets.Count)
ActiveSheet.Name = sheet_meno
End If
End If
Next pocet_tabov
For pocet_tabov = 1 To (Sheets.Count - 1)
For netusim = pocet_tabov + 1 To Sheets.Count
If Right(Sheets(pocet_tabov).Name, 10) > _
Right(Sheets(netusim).Name, 10) Then
Sheets(netusim).Move before:=Sheets(pocet_tabov)
End If
Next netusim
Next pocet_tabov
Sheets(1).Activate
Application.ScreenUpdating = True
End Sub
Now I need to copy prepared template from for example "C:\Troll\Template.xlsx" into all of theese created sheets. Additionally, template includes this formula: ='C:\Troll[source.xls]1.febr'!$U$33
I need this one to be updated in every new sheet. So the sheet with name 01.Feb.2014 needs to have template copied from [source.xls]1.febr'!$U$33, second sheet 02.Feb.2014 needs to have [source.xls]2.febr'!$U$33 and so on.
I was trying to do the copy - that worked. However I'm not able to join it with this one to be one big script.
Copying:
Public Function kopirovanie(sheet_meno As String)
Dim bWasClosed As Boolean
Dim cesta As String
Dim zdroj As Workbook
Dim ciel As Workbook
'Set ciel = Workbooks("template for copy.xlsx")
Set ciel = ActiveWorkbook ' for testing
' just in case the source wb is already open...
On Error Resume Next ' avoid the error if not open
Set zdroj = Workbooks("template for copy.xlsx")
On Error GoTo 0
If zdroj Is Nothing Then
bWasClosed = True
cesta = "C:\Project Tata\Kopirovanie\"
Set zdroj = Application.Workbooks.Open(cesta & "template for copy.xlsx")
End If
zdroj.Worksheets("Sheet1").Copy before:=ciel.Worksheets("Sheet1")
If bWasClosed Then
zdroj.Close False ' close without saving
End If
End Function
the function is supposed to be called after this
If pocet_tabov <= Sheets.Count Then
If Left(Sheets(pocet_tabov).Name, 5) = "Sheet" Then
Sheets(pocet_tabov).Name = sheet_meno
But I get error that copying is out of range. I think that I need to specify that it should copy regardless of the Tab name. Or actually I want it to copy into Active sheet...
the error is "Run-time error'9'" Subscript out of range.. and it marks me this one yellow: zdroj.Worksheets("Sheet1").Copy before:=ciel.Worksheets("Sheet1")
!! Look for the comments - part of this was already solved.
Now to continue with changing formula:
I have two docs. Lets call them Source.xls and Results.xls
Results doc has the macro you've wrote in it. That means we've copied 1 table that is exactly the same in all the newly created sheets - that's a part fo the job. However if I would do this with the table I have I would end up with Workbook created for 31 days of the month where is table with formula " ='C:\Troll[data_source.xls]1.febr'!$U$33 " .. this would end up with every day of Results showing results of the 1.st february of the data_source.
I need worksheet that was created for 1st feb, to get data from 1st feb, sheet for 2nd to get data from 2nd feb and so on.. Please be aware that source of table with formula and source of data which formula refers to are 2 different workbooks
I think this macro meets the first part of your requirement.
I have used your variable names when I am confident that I understand then. I have used my own names for other variables. I suggest you avoid renaming them until we have met your entire requirement.
I have not explained my new code. I did not want to spent time doing so if it does not meet your requirement. I am happy to explain anything you want to understand.
I use Excel 2003 so my extensions are different to yours. Change "xls" to "xlsx" before trying the macro.
I have three workbooks:
The workbook containing the macro.
The workbook containing the template worksheet. I have used your name for this workbook (except for the extension) but have changed the path to the folder holding the macro workbook.
The workbook created by the macro. I have named this Format(datum, "yyyy mmm"). Again I have changed the path to the folder holding the macro workbook.
You can change the paths immediately or you can wait until we have finished development.
Edit The remainder of this answer has been replaced.
The revised code below now updates the formula in cell C3 of each sheet created in WbookCreate. I believe I have made the correct change so the formula references the correct worksheet in workbook Source.xlsx.
However, I have made another change. In the original code, I named the created sheets as "dd.MMM.yyyy". I believe that was incorrect and I should have named then as "d.MMM". However, in the new code I name them as "d" and have added a statement to adjust the TabRatio. This means that all the tabs are visible at the same time. This is just a demonstration of what is possible; you can easily change to any name you prefer.
Option Explicit
Sub CreateDailySheets()
Const WbookCopyName As String = "template for copy.xls"
Dim datumCrnt As Date
Dim datumStart As Date
Dim Formula As String
Dim InxWbook As Long
Dim InxWsheet As Long
Dim PathCopy As String
Dim PathCreate As String
Dim PosLastSquare As Long
Dim PosLastQuote As Long
Dim WbookCopy As Workbook
Dim WbookCopyWasClosed As Boolean
Dim WbookCreate As Workbook
Dim WbookThis As Workbook
Dim zadany_mesiac As Long
Set WbookThis = ThisWorkbook
' These set the paths for the template workbook and the workbook to be
' created to that for the workbook containing the macro. Change as
' required.
PathCopy = WbookThis.Path
PathCreate = WbookThis.Path
' Check for template workbook being open
WbookCopyWasClosed = True
For InxWbook = 1 To Workbooks.Count
If Workbooks(InxWbook).Name = WbookCopyName Then
WbookCopyWasClosed = False
Set WbookCopy = Workbooks(InxWbook)
Exit For
End If
Next
If WbookCopyWasClosed Then
' Template workbook is not open so open it
Set WbookCopy = Workbooks.Open(PathCopy & "\" & WbookCopyName, True)
End If
' Create an empty workbook
Set WbookCreate = Workbooks.Add
' WbookCreate is now the active workbook
' Get the month of the current year for which workbook is to be created
zadany_mesiac = 13
While (zadany_mesiac < 1) Or (zadany_mesiac > 12)
zadany_mesiac = Val(InputBox("Numeric month?"))
If zadany_mesiac = 0 Then Exit Sub
Wend
'Calculate first day of target month
datumStart = DateSerial(Year(Now()), zadany_mesiac, 1)
datumCrnt = datumStart
' Loop until datumCrnt is within the next month
Do While Month(datumCrnt) = Month(datumStart)
' Copy template worksheet from template workbook and name for day
WbookCopy.Worksheets("Sheet1").Copy _
After:=WbookCreate.Worksheets(Worksheets.Count)
With ActiveSheet
' In original code, I had "dd.MMM.yyyy" but I believe this should have
' been "d.MMM". However, I have changed to just "d" because with the
' TabRatio set to .7 all the tab names are visible. You can change this
' easily to your preferred value.
.Name = Format((datumCrnt), "d")
Formula = .Range("C3").Formula
PosLastSquare = InStrRev(Formula, "]")
PosLastQuote = InStrRev(Formula, "'")
If PosLastSquare <> 0 And PosLastQuote <> 0 And _
PosLastQuote > PosLastSquare Then
' Sheet name is bracketed by PosLastSquare and posLastQuote
' Replace sheet name from template with one required for this sheet
Formula = Mid(Formula, 1, PosLastSquare) & Format((datumCrnt), "d.MMM") & _
Mid(Formula, PosLastQuote)
.Range("C3").Formula = Formula
End If
End With
datumCrnt = DateAdd("d", 1, datumCrnt)
Loop
' Delete default worksheet
With WbookCreate
' The default sheets are at the beginning of the list
Do While Left(.Worksheets(1).Name, 5) = "Sheet"
Application.DisplayAlerts = False ' Surpress "Are you sure" message
.Worksheets(1).Delete
Application.DisplayAlerts = True
Loop
.Worksheets(1).Activate
End With
ActiveWindow.TabRatio = 0.7
WbookCreate.SaveAs PathCreate & "\" & Format(datumStart, "yyyy mmm")
If WbookCopyWasClosed Then
' Template workbook was not open so close
WbookCopy.Close SaveChanges:=False
End If
End Sub

Excel VBA - UsingVBA to create a new, formatted workbook

I'm trying to write the last part of my program and I need to pull data from an Access document and print it into a new Workbook.
To start, I will be taking the names of product Suppliers and creating a Worksheet with each suppliers name, then I want to be looping through each sheet and printing the products from each supplier that were ordered.
I'm really struggling with wrapping my head around how to open a new workbook and print in my info.
As my previous answer was deleted (considered "insuficient"), I have to provide a better one.
If you want to output data from Access to Excel, you have to follow this steps:
Create (or open) a new workbook
Read your data
Write your data to the workbook
Format the data in the workbook
I will focus on the data output, and leave the formatting out (the data part is the complicated one... formatting is easy)
First, you need to enable the Excel objects in your Access file: Tools Menu > References. Find the Microsoft Excel 12.0 Object Library and activate the checkbox. Now you have the full Excel library at your service :-)
Now is the time for the data crunching. I will asume that you need to create a new workbook:
public sub createExcelFile()
dim XL as Excel.Application, WB as Excel.Workbook, WKS as Excel.Worksheet
dim db as DAO.database, rec as DAO.recordset, f as DAO.field
dim i as integer, j as integer
' Prepare your Excel stuff
Set XL = new Excel.Application
XL.Visible = True
Set WB = XL.Workbooks.Add
WB.Activate
Set WKS = WB.ActiveSheet ' Default: The first sheet in the newly created book
' Read your data here
set db = currentdb()
set rec = db.openrecordset("tblSampleData")
' A simple table that will show the data from rec
' i and j will be the coordiantes of the active cell in your worksheet
with rec
.movefirst
' The table headers
i = 1
j = 1
for each f in .fields
WKS.cells(i,j).value = f.name
j = j + 1
next f
' The table data
do
i = i+1
j = 1
for each f in .Fields
WKS.cells(i,j).value = f.value
j = j+1
next f
.moveNext
loop until .EOF
end with
end sub
If you want to format the cells, you can use the WKS.cells(i,j) (or WKS.range(...)) properties.
Take a look at the link I leaved before (which Siddarth Rout was kind to move to the comments).
I hope this helps you
Option Compare Database
Public Function format(filepath, sheetname)
Set xls = CreateObject("EXCEL.APPLICATION")
xls.screenupdating = False
xls.displayalerts = False
xls.Visible = True
xls.workbooks.Open filepath
Set xlsdd = xls.ActiveWorkbook
'deleting headers
xls.Range("1:1").Select
xls.Selection.Delete Shift:=xlUp
'adding one column
xls.Columns("A:A").Select
xls.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'adding 5 rows
'ActiveWorkbook.Sheets("sheet1").Select
xls.Rows("1:5").Insert Shift:=xlDown
'fetching rows from access and putting them into excel
strsql = "select top 5 " & sheetname & ".* into top5_records from " & sheetname
DoCmd.RunSQL strsql
outputFileName = "C:\Users\hp\Desktop\top5_records.xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "top5_records", outputFileName, True
'then open that excel and copy the rows
Set xls2 = CreateObject("EXCEL.APPLICATION")
xls2.screenupdating = False
xls2.displayalerts = False
xls2.Visible = True
xls2.workbooks.Open outputFileName
Set xlsdd2 = xls.ActiveWorkbook
xls2.Rows("1:5").Select
xls2.Selection.Copy
xls.Cells(1, 1).Select
xls.activesheet.Paste
' Dim currdb As DAO.Database
' Dim rst As DAO.Recordset
'
' Set currdb = CurrentDb
' Set rst = currdb.OpenRecordset(strsql) '<<<Opens query recordset via DAO
' rst.MoveLast
' rowsToReturn = rst.RecordCount
' Set rng = xls.Cells(1, 1)
' 'copy specified number of records to worksheet
'
'rng.CopyFromRecordset rst, rowsToReturn '<<<Gets all records in recordset
'making first 6th row to be bold
xls.Rows("6:6").Select
With xls.Selection.Font
.Bold = True
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
'autofit the data
xls.Sheets(sheetname).Cells.Columns.autofit
xls.CutCopyMode = False
With xlsdd
.Save
.Close
End With
xls.Visible = False
Set xlsdd = Nothing
Set xls = Nothing
End Function
You can define column/row widths to a static pixel amount or auto-fit, things like bold are a pre-defined
Example Selection.Font.Bold = True
You can also make a template spreadsheet, copy the contents into the template and save as.
Your post does not indicate how much formatting actually needs to be done.
You don't give a lot of details, so I can't give you a lot of details in return. But here's how I would do it:
Create a new workbook manually with two sheets
On one sheet, add an External Data table that returns a list of supplier's name like SELECT SupplierName FROM tblSuppliers WHERE Active=True; or something like that.
Create a workbook-level named range that dynamically expands with that query table
On the second sheet, add an External Data table like SELECT * FROM Orders WHERE SupplierName=? (This will be a parameter query). Start that external data table in row 3
I row, put a combobox box that points back to the supplier list.
Now the VBA is simple
ThisWorkbook.RefreshAll
Instead of one sheet per supplier, you'll have one sheet on which you can change the supplier. Here are the skills you'll need
Create an external data table
Create a parameter query (old reference http://www.dicks-clicks.com/excel/ExternalData6.htm)
Create dynamically expanding range name
Add a combobox or data validation that points to a range on a different sheet
That SQL above is obviously not right, but I assume you can write the correct SQL statement
You should be able to find details on all that, but if not, post another question.

How to copy data from another workbook (excel)?

I already have a macro that creates sheets and some other stuff. After a sheet has been created do I want to call another macro that copies data from a second excel (its open) to first and active excel file.
First I want to copy to headers, but I cant get that to work - keep getting errors.
Sub CopyData(sheetName as String)
Dim File as String, SheetData as String
File = "my file.xls"
SheetData = "name of sheet where data is"
# Copy headers to sheetName in main file
Workbooks(File).Worksheets(SheetData).Range("A1").Select # fails here: Method Select for class Range failed
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
End Sub
What is wrong ?
I really want to avoid having to make "my file.xls" active.
Edit: I had to give it up and copy the SheetData to target file as a new sheet, before it could work.
Find and select multiple rows
Two years later (Found this on Google, so for anyone else)... As has been mentioned above, you don't need to select anything. These three lines:
Workbooks(File).Worksheets(SheetData).Range("A1").Select
Workbooks(File).Worksheets(SheetData).Range(Selection, Selection.End(xlToRight)).Select
Workbooks(File).Worksheets(SheetData).Selection.Copy ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
Can be replaced with
Workbooks(File).Worksheets(SheetData).Range(Workbooks(File).Worksheets(SheetData). _
Range("A1"), Workbooks(File).Worksheets(SheetData).Range("A1").End(xlToRight)).Copy _
Destination:=ActiveWorkbook.Sheets(sheetName).Cells(1, 1)
This should get around the select error.
Best practice is to open the source file (with a false visible status if you don't want to be bother) read your data and then we close it.
A working and clean code is avalaible on the link below :
http://vba-useful.blogspot.fr/2013/12/how-do-i-retrieve-data-from-another.html
Would you be happy to make "my file.xls" active if it didn't affect the screen? Turning off screen updating is the way to achieve this, it also has performance improvements (significant if you are doing looping while switching around worksheets / workbooks).
The command to do this is:
Application.ScreenUpdating = False
Don't forget to turn it back to True when your macros is finished.
I don't think you need to select anything at all. I opened two blank workbooks Book1 and Book2, put the value "A" in Range("A1") of Sheet1 in Book2, and submitted the following code in the immediate window -
Workbooks(2).Worksheets(1).Range("A1").Copy Workbooks(1).Worksheets(1).Range("A1")
The Range("A1") in Sheet1 of Book1 now contains "A".
Also, given the fact that in your code you are trying to copy from the ActiveWorkbook to "myfile.xls", the order seems to be reversed as the Copy method should be applied to a range in the ActiveWorkbook, and the destination (argument to the Copy function) should be the appropriate range in "myfile.xls".
I was in need of copying the data from one workbook to another using VBA. The requirement was as mentioned below 1. On pressing an Active X button open the dialogue to select the file from which the data needs to be copied. 2. On clicking OK the value should get copied from a cell / range to currently working workbook.
I did not want to use the open function because it opens the workbook which will be annoying
Below is the code that I wrote in the VBA. Any improvement or new alternative is welcome.
Code: Here I am copying the A1:C4 content from a workbook to the A1:C4 of current workbook
Private Sub CommandButton1_Click()
Dim BackUp As String
Dim cellCollection As New Collection
Dim strSourceSheetName As String
Dim strDestinationSheetName As String
strSourceSheetName = "Sheet1" 'Mention the Source Sheet Name of Source Workbook
strDestinationSheetName = "Sheet2" 'Mention the Destination Sheet Name of Destination Workbook
Set cellCollection = GetCellsFromRange("A1:C4") 'Mention the Range you want to copy data from Source Workbook
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
'.Filters.Add "Macro Enabled Xl", "*.xlsm;", 1
For intWorkBookCount = 1 To .SelectedItems.Count
Dim strWorkBookName As String
strWorkBookName = .SelectedItems(intWorkBookCount)
For cellCount = 1 To cellCollection.Count
On Error GoTo ErrorHandler
BackUp = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount))
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = GetData(strWorkBookName, strSourceSheetName, cellCollection.Item(cellCount))
Dim strTempValue As String
strTempValue = Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)).Value
If (strTempValue = "0") Then
strTempValue = BackUp
End If
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = strTempValue
ErrorHandler:
If (Err.Number <> 0) Then
Sheets(strDestinationSheetName).Range(cellCollection.Item(cellCount)) = BackUp
Exit For
End If
Next cellCount
Next intWorkBookCount
End With
End Sub
Function GetCellsFromRange(RangeInScope As String) As Collection
Dim startCell As String
Dim endCell As String
Dim intStartColumn As Integer
Dim intEndColumn As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim coll As New Collection
startCell = Left(RangeInScope, InStr(RangeInScope, ":") - 1)
endCell = Right(RangeInScope, Len(RangeInScope) - InStr(RangeInScope, ":"))
intStartColumn = Range(startCell).Column
intEndColumn = Range(endCell).Column
intStartRow = Range(startCell).Row
intEndRow = Range(endCell).Row
For lngColumnCount = intStartColumn To intEndColumn
For lngRowCount = intStartRow To intEndRow
coll.Add (Cells(lngRowCount, lngColumnCount).Address(RowAbsolute:=False, ColumnAbsolute:=False))
Next lngRowCount
Next lngColumnCount
Set GetCellsFromRange = coll
End Function
Function GetData(FileFullPath As String, SheetName As String, CellInScope As String) As String
Dim Path As String
Dim FileName As String
Dim strFinalValue As String
Dim doesSheetExist As Boolean
Path = FileFullPath
Path = StrReverse(Path)
FileName = StrReverse(Left(Path, InStr(Path, "\") - 1))
Path = StrReverse(Right(Path, Len(Path) - InStr(Path, "\") + 1))
strFinalValue = "='" & Path & "[" & FileName & "]" & SheetName & "'!" & CellInScope
GetData = strFinalValue
End Function