I have a workbook with several worksheets that each contain an inventory list. Within that workbook I have another "Generate Order" worksheet that contains a table, which I've set up to consolidate the data from the other sheets. I would like a button on that sheet called "Export Order," which would export the contents of the generateOrder table as a .csv file.
The catch is, in order to upload the order to the vendor's system, the .csv file must only contain the item number and the quantity, set up as "number,quantity" with each item on its own line.
Currently I have this macro set up:
Sub export_button()
Dim tbl As ListObject
Dim csvFilePath As String
Dim fNum As Integer
Dim tblArr
Dim rowArr
Dim csvVal
Set tbl = Worksheets("Generate Order").ListObjects("generateOrder")
csvFilePath = "C:\Users\username\Desktop\order.csv"
tblArr = tbl.DataBodyRange.Value
fNum = FreeFile()
Open csvFilePath For Output As #fNum
For i = 1 To UBound(tblArr)
rowArr = Application.Index(tblArr, i, 0)
csvVal = VBA.Join(rowArr, ",")
Print #1, csvVal
Next
Close #fNum
Set tblArr = Nothing
Set rowArr = Nothing
Set csvVal = Nothing
End Sub
Through a lot of Googling I've managed to get it working so that it does export the contents of generateOrder and save it as a .csv, but I'm trying to figure out the following modifications:
I would like to export only the two columns named PUBLISHER ITEM #,REORDER QTY (in that order). If it matters, there's a line break between PUBLISHER and ITEM in the first column header.
I would like the file to be named value in cell C3-order-current date.csv
If they don't already exist, I'd like the macro to create a subfolder called "Orders" within the same folder where the workbook is located, and then create a subfolder inside Orders named value in cell C3, and then save the file there (instead of to the Desktop as it currently does).
I need to figure out all of that but if you can at least help me figure out how to get only the two columns, I can try figuring out how to save it the way I want later. Many thanks!
Collect the column index numbers of the two desired columns from the listobject's header row and use those to parse the array of databodyrange values.
dim c1 as long, c2 as long
Set tbl = Worksheets("Generate Order").ListObjects("generateOrder")
csvFilePath = "C:\Users\username\Desktop\order.csv"
tblArr = tbl.DataBodyRange.Value
'you should really know where the two columns are but this should fetch their
'position from the header row. Hard-code the positions if you run into trouble.
c1 = application.match("publisher" & vblf & "item #", tbl.HeaderRowRange, 0)
c2 = application.match("reorder qty", tbl.HeaderRowRange, 0)
fNum = FreeFile()
Open csvFilePath For Output As #fNum
For i = LBound(tblArr, 1) To UBound(tblArr, 1)
csvVal = Join(array(tblArr(i, c1), tblArr(i, c2)), ",")
Print #1, csvVal
Next
Note that I'm looking up "publisher" & vblf & "item #" with no space after publisher. Multi-line values in an excel cell only use line feed; not carriage return and line feed.
Related
I found this code by #Scott Holtzman and I need to tweek it a bit to match my needs. This code takes each line in a text file and puts it into seperate columns in an excel sheet(A1, B1, C1 and so on), each text file is stored in a seperate row(1,2,3 and so on). First i want it to only put text into the excel sheet if the line starts with a specific text, second i want it to only copy some of the text from each line into the excel sheet.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder, file As file, FileText As TextStream
Dim TextLine As String, Items() As String
Dim i As Long, cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("D:\YourDirectory\")
Dim x As Long
x = 1 'to offset rows for each file
' Loop thru all files in the folder
For Each file In folder.Files
' set the starting point to write the data to
Set cl = ActiveSheet.Cells(x, 1)
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
Dim j As Long
j = 0 'to offset columsn for each line
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine 'read line
cl.Offset(, j).Value = TextLine 'fill cell
j = j + 1
Loop
' Clean up
FileText.Close
x = x + 1
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
Here is what my text files look like:
From:NameName 'want all text except the "FROM:"
Date:yyyy.mm.dd 'want all text except the "Date:"
Type: XXXXXXXXX ' I don't want this line into excel
To: namename ' I don't want this line into excel
----------------------------- xxxxxxx ---------------------
A1: Tnr xxxxxxxxxxxxx 'want all text except the "A1: Tnr" only next 13char
A2: texttext 'want all text except the "A2:"
An: 'A1 and up to A14
A14: texttext 'want all text except the "A14:"
------------------------------ xxxxxx ----------------------
So in total there is 22 lines in the text file.
And if it is possible to use the FROM:, DATE:, A1: to A14: as headers in the first row that would be epic.
have tried to google my way to it, and tried a bit with this:
TextLine = FileText.ReadLine 'read line
If InStr(TextLine, "A1:")
but that works only for one line and i cant seem to get it to work with several lines. In addition it puts the output in cell F1, instead of A1. think this is since each line in text document gets one cell - even if nothing is written to it.
Here is a solution that fills one row in the Excel sheet per file, starting at row 2. You should manually fill in the titles in that first row as follows:
From | Date | A1 | A2 | ... | A14
The lines that you are not interested in are skipped, and the values are put in the correct columns:
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder, file As file, FileText As TextStream
Dim TextLine As String
Dim cl As Range
Dim num As Long ' numerical part of key, as in "Ann:"
Dim col As Long ' target column in Excel sheet
Dim key As String ' Part before ":"
Dim value As String ' Part after ":"
' Get a FileSystem object
Set fso = New FileSystemObject
' Get the directory you want
Set folder = fso.GetFolder("D:\YourDirectory\")
' Set the starting point to write the data to
' Don't write in first row where titles are
Set cl = ActiveSheet.Cells(2, 1)
' Loop thru all files in the folder
For Each file In folder.Files
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine 'read line
key = Split(TextLine & ":", ":")(0)
value = Trim(Mid(TextLine, Len(key)+2))
num = Val(Mid(key,2))
If num Then key = Replace(key, num, "") ' Remove number from key
col = 0
If key = "From" Then col = 1
If key = "Date" Then col = 2
If key = "A" Then col = 2 + num
If col Then
cl.Offset(, col-1).Value = value ' Fill cell
End If
Loop
' Clean up
FileText.Close
' Next row
Set cl = cl.Offset(1)
Next file
End Sub
The above code will work well even if items are missing in your file, like if the line with "A12:" would not be present, this will leave the corresponding cell in the sheet empty, instead of putting the value of "A13:" there, causing a shift.
Even if the order of the lines would change, and "From:" would appear after "Date:", this will not have a negative effect in the output. "From" values will always get into the first column, "Date" values in the second, etc.
Also, if your file would contain many other lines with differing formats, they will all be ignored.
Replace the "Do While's" body with the following lines
TextLine = FileText.ReadLine 'read line
If Not (Left(TextLine, 1) = "T" Or Left(TextLine, 1) = "-") Then
TextLine = Trim(Mid(TextLine, InStr(TextLine, ":") + 1))
If (TextLine <> "") Then
cl.Offset(, j).Value = TextLine 'fill cell
j = j + 1
End If
End If
Using Microsoft Excel 2010, this macro searches for a list of phrases within a folder of text reports. For each phrase, it searches all of the reports and lists each report that contains the phrase.
I found some better macros to do each part of the macro - such as enumerating a directory, or finding a phrase within a text file - although I had a really hard time putting them together successfully. Despite it not being perfect, it may be helpful for others with the same problem, and I hope for some feedback on how to improve and optimize the macro.
Basic overview:
Column A: list of full path to text reports (for instance, "C:\path\to\report.txt")
Column B: name of report (such as "report.txt")
Column C: list of phrases to search for
Columns D+: output showing each report that contains the phrase (column C)
Areas for improvement:
Make the macro run faster! (This took over an hour for 360 reports and 1100 phrases)
Select the reports and report folder from a pop-up or other function (currently entered into the spreadsheet using another macro)
Filter reports by file name (for instance, only check reports with a word or phrase in the file name)
Filter reports by file extension (for instance, only check .txt files and not .xlsx files)
Detect the number of reports and phrases (currently this is hard coded)
Other suggestions / areas for improvement
Code:
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim findCount As Integer
Dim i As Integer
Dim j As Integer
For i = 2 To 1109
searchTerm = Range("C" & i).Value
findCount = 0
For j = 2 To 367
fn = Range("A" & j).Value
fileName = Range("B" & j).Value
With CreateObject("Scripting.FileSystemObject").OpenTextFile(fn)
Do While Not .AtEndOfStream
lineString = .ReadLine
If InStr(1, lineString, searchTerm, vbTextCompare) Then
findCount = findCount + 1
Cells(i, 3 + findCount) = fileName
GoTo EarlyExit
End If
Loop
EarlyExit:
.Close
End With
Next j
Next i
End Sub
As #Makah pointed out, you're opening a lot of files, which is slow. To fix this, change the order of the loops (see the code below). This will switch from 407,003 file opens to 367. Along the same lines, lets create the FileSystemObject once, instead of once per file open.
Also, VBA is surprisingly slow at reading/writing data from/to Excel. We can deal with this by loading largw blocks of data into VBA all at once with code like
dim data as Variant
data = Range("A1:Z16000").value
And then writing it back to Excel in a large block like
Range("A1:Z16000").value = data
I have also added in code to dynamically check the dimension of your data. We assume that the data starts in cell A2, and if A3 is empty, we use the single cell A2. Otherwise, we use .End(xlDown) to move down to just above the first empty cell in column A. This is the equivalent of pressing ctrl+shift+down.
Note: the following code has not been tested. Also, it requires a reference to "Microsoft Scripting Runtime" for the FileSystemObjects.
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim i As Integer, j As Integer
Dim FSO As Scripting.FileSystemObject
Dim txtStr As Scripting.TextStream
Dim file_rng As Range, file_cell As Range
Dim output As Variant
Dim output_index() As Integer
Set FSO = New Scripting.FileSystemObject
Set file_rng = Range("A2")
If IsEmpty(file_rng) Then Exit Sub
If Not IsEmpty(file_rng.Offset(1, 0)) Then
Set file_rng = Range(file_rng, file_rng.End(xlDown))
End If
If IsEmpty(Range("C2")) Then Exit Sub
If IsEmpty(Range("C3")) Then
output = Range("C2")
Else
output = Range(Range("C2"), Range("C2").End(xlDown))
End If
ReDim Preserve output(1 To UBound(output, 1), 1 To file_rng.Rows.Count + 1)
ReDim output_index(1 To UBound(output, 1))
For i = 1 To UBound(output, 1)
output_index(i) = 2
Next i
For Each file_cell In file_rng
fn = file_cell.Value 'Range("A" & j)
fileName = file_cell.Offset(0, 1).Value 'Range("B" & j)
Set txtStr = FSO.OpenTextFile(fn)
Do While Not txtStr.AtEndOfStream
lineString = txtStr.ReadLine
For i = 1 To UBound(output, 1)
searchTerm = output(i, 1) 'Range("C" & i)
If InStr(1, lineString, searchTerm, vbTextCompare) Then
If output(i, output_index(i)) <> fileName Then
output_index(i) = output_index(i) + 1
output(i, output_index(i)) = fileName
End If
End If
Next i
Loop
txtStr.Close
Next file_cell
Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
Set txtStr = Nothing
Set FSO = Nothing
Set file_cell = Nothing
Set file_rng = Nothing
End Sub
I have a source spreadsheet in Excel with 450-or-so rows. Each row has 6 columns of data, and I need to create a separate file from each row with the filename = Column A and the contents = Columns B-G with a line break between them.
For example, I'm trying this but getting an error "File not found":
Sub DataDump()
Dim X
Dim lngRow As Long
Dim StrFolder As String
StrFolder = "/Users/danielfowler/Documents/_users_text_6.16"
X = Range([a1], Cells(Rows.Count, 2).End(xlUp))
For lngRow = 1 To UBound(X)
Open StrFolder & "\" & X(lngRow, 1) & ".txt" For Output As #1
Write #1, X(lngRow, 2)
Close #1
Next
End Sub
I see a half dozen questions like this already here on StackOverflow...
Create text Files from every row in an Excel spreadsheet
Write each Excel row to new .txt file with ColumnA as file name
Outputting Excel rows to a series of text files with spaces in filenames using VBA
Outputting Excel rows to a series of text files
But every one of these solutions returns a different error for me. I'm using Excel for Mac 2011, v14.4.2.
Sub VBA_Print_to_a_text_file()
Dim strFile_Path As String
strFile_Path = "C:\temp\test.txt" ‘Change as per your test folder path
Open strFile_Path For Output As #1
Print #1, "This is my sample text"
Close #1
End Sub
This outputs a text file for each row with column A as the title and columns B to the last column as the content for each file. You can change the directory to whatever you want but currently it saves the text file(s) to the same directory as the Excel file. You can also change the file extension to whatever you want.
Sub toFile()
Dim FilePath As String, CellData As String, LastCol As Long, LastRow As Long
Dim Filenum As Integer
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 1 To LastRow
FilePath = Application.DefaultFilePath & "\" & Trim(ActiveSheet.Cells(i, 1).Value) & ".xpd"
Filenum = FreeFile
Open FilePath For Output As Filenum
CellData = ""
For j = 2 To LastCol
CellData = Trim(ActiveSheet.Cells(i, j).Value)
Write #Filenum, CellData
Next j
Close #Filenum
Next i
MsgBox ("Done")
End Sub
As for the breaks in between each line, unfortunately I'm not experienced enough to know how to do that.
I have a spreadsheet with a whole bunch of data (A directory of weather stations) which calculates the closest weather stations to a user entered Latitude and Longitude. This worksheet achieves this by calculating distance from the entered point, ranking those distances using SMALL() and then an excel TABLE/List with formulas perform Index(Match()) type calculations using Rankings (1 is closest, 2 is 2nd closest etc).
The worksheet whilst slow, works fairly well - and the excel Tables allow for advanced sorting of the weather station directory by various criteria (Such as length of record in years etc).
I have a VBA Macro that I was writing which used to work, but stopped working when I tried to fix it (awesome).
The purpose of the VBA Macro is to write a Google Earth KML file with the lat/long/weather station name and then to launch that file into google earth so the user can visualise the proximate stations around a set site location (the one previously entered by the user).
Unfortunately the original method I used couldn't handle the Filtered Results of the List, such that if the user filtered the results (Such that the first 4 weather stations were filtered out as an example) the macro would still write the first four weather stations that were not Visible/Were Filtered.
The problem for me is made more difficult as I wish to have only one macro for four worksheets with filter-able tables - for different data types.
At this stage the data the macro needs are stored in the Tables in identically named Table Columns: {"STATION","LONGITUDE","LATITUDE"} in different worksheets. The majority of the KML strings required to write to the KML file are stored in another hidden worksheet "KML".
The macro is launched via a button on each of these pages.
I understand that there could be a solution using ".SpecialCells(xlCellTypeVisible)" - and I've tried extensively to get it to work with my Tables - but have had no luck so far - probably due to my lack of formal training.
Any help appreciated, be it a solution or a suggestion! Apologies for my bad code, the problem loop & broken code area is about halfway down - after 'Find all table on active sheet:
Sub KML_writer()
Dim FileName As String
Dim StrA As String
Dim NumberOfKMLs
Dim MsgBoxResponse
Dim MsgBoxTitle
Dim MsgBoxPrompt
Dim WhileCounter
Dim oSh As Worksheet
Set oSh = ActiveSheet
'Prompt the Number of Stations to Write to the KML File
NumberOfKMLs = InputBox(Prompt:="Please Enter the number of Weather Stations to generate within the Google Earth KML file", _
Title:="Number of Weather Stations", Default:="10")
'Prompt a File Name
FileName = InputBox(Prompt:="Please Enter a name for your KML File.", _
Title:="Lat Long to KML Converter", Default:="ENTER FILE NAME")
'Will clean this up to not require Write to Cell and Write to KML duplication later
Sheets("kml").Range("B3").Value = FileName
Sheets("mrg").Range("C5").Value = "Exported from EXCEL by AJK's MRG Function"
saveDir = "H:\" 'Local Drive available for all users of macro
targetfile = saveDir & FileName & ".KML"
'Write Site Location to KML STRING - user entered values from SITE LOCATION worksheet
StrA = Sheets("kml").Range("B1").Value & Sheets("kml").Range("B2").Value & "SITE LOCATION" & Sheets("kml").Range("B4").Value & Sheets("INPUT COORDINATES").Range("E5").Value & Sheets("kml").Range("B6").Value & Sheets("INPUT COORDINATES").Range("E4").Value & Sheets("kml").Range("B8").Value
'Find all tables on active sheet
Dim oLo As ListObject
For Each oLo In oSh.ListObjects
'
Dim lo As Excel.ListObject
Dim lr As Excel.ListRow
Set lo = oSh.ListObjects(oLo.Name)
Dim cl As Range, rng As Range
Set rng = Range(lo.ListRows(1)) 'this is where it breaks currently
For Each cl In rng2 '.SpecialCells(xlCellTypeVisible)
'Stop looping when NumberofKMLs is written to KML
WhileCounter = 0
Do Until WhileCounter > (NumberOfKMLs - 1)
WhileCounter = WhileCounter + 1
Dim St
Dim La
Dim Lon
'Store the lr.Range'th station data to write to the KML
St = Intersect(lr.Range, lo.ListColumns("STATION").Range).Value
La = Intersect(lr.Range, lo.ListColumns("LATITUDE").Range).Value
Lon = Intersect(lr.Range, lo.ListColumns("LONGITUDE").Range).Value
'Write St La Long & KML Strings for Chosen Stations
StrA = StrA & Sheets("kml").Range("B2").Value & St & Sheets("kml").Range("B4").Value & Lon & Sheets("kml").Range("B6").Value & La & Sheets("kml").Range("B8").Value
Loop
Next
Next
'Write end of KML strings to KML File
StrA = StrA & Sheets("kml").Range("B9").Value
'Open, write, close KML file
Open targetfile For Output As #1
Print #1, StrA
Close #1
'Message Box for prompting the launch of the KML file
MsgBoxTitle = ("Launch KML?")
MsgBoxPrompt = "Would you like to launch the KML File saved at " & targetfile & "?" & vbCrLf & vbCrLf & "Selecting 'No' will not prevent the file from being written."
MsgBoxResponse = MsgBox(MsgBoxPrompt, vbYesNo, MsgBoxTitle)
If MsgBoxResponse = 6 Then ThisWorkbook.FollowHyperlink targetfile
End Sub
Here is an example of iteration over a filtered table. This uses a ListObject table which are a little easier to work with than just a range of autofiltered cells arranged like a table, but the same general idea can be used (except you can't call on the DataBodyRange of a non-ListObject table).
Create a table:
Apply some filter(s) to it:
Notice that several rows have been hidden, and the visible rows are not necessarily contiguous, so we need to use the .Areas of the table's DataBodyRange which are visible.
As you've already surmised, you can use the .SpecialCells(xlCellTypeVisible) to do this.
Here's an example:
Sub TestFilteredTable()
Dim tbl As ListObject
Dim rngTable As Range
Dim rngArea As Range
Dim rngRow As Range
Set tbl = ActiveSheet.ListObjects(1)
Set rngTable = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
' Here is the address of the table, filtered:
Debug.Print "Filtered table: " & rngTable.Address
'# Here is how you can iterate over all
' the areas in this filtered table:
For Each rngArea In rngTable.Areas
Debug.Print " Area: " & rngArea.Address
'# You will then have to iterate over the
' rows in every respective area
For Each rngRow In rngArea.Rows
Debug.Print " Row: " & rngRow.Address
Next
Next
End Sub
Sample output:
Filtered table: $A$2:$G$2,$A$4:$G$4,$A$6:$G$6,$A$9:$G$10
Area: $A$2:$G$2
Row: $A$2:$G$2
Area: $A$4:$G$4
Row: $A$4:$G$4
Area: $A$6:$G$6
Row: $A$6:$G$6
Area: $A$9:$G$10
Row: $A$9:$G$9
Row: $A$10:$G$10
Try and adapt this method to your problem, and if you have a specific error/issue with implementing it, let me know.
Just remember to update your original question to indicate a more specific problem :)
I had to find a record in a filtered data and change one value
Sample data
I wanted to change sales personcode to customer C00005.
First i filtered and found customer to modify.
codcliente = "C00005"
enter 'make sure that this customer exist in the checked range
Set test = CheckRng.Find(What:=codcliente, LookIn:=xlValues, LookAt:=xlWhole)
If test Is Nothing Then
MsgBox ("Does not exist customer """ & codcliente & """ !")
DataSheet.AutoFilterMode = False
Else 'Customer Exists
With DataRng 'filter the customer
.AutoFilter Field:=1, Criteria1:=codcliente
End With
Set customer = DataRng.SpecialCells(xlCellTypeVisible) ´Get customer data. It is visible
customer.Cells(1, 6).Value = "NN" 'navigate to 6th column and change code
End If
enter image description here
I'd like to copy a table like this in a word document and extract only the track titles and composers. The selecting of the range goes according to plan:
Dim myCells As Range
With ActiveDocument
Set myCells = .Range(Start:=.Tables(1).Cell(2, 3).Range.Start, _
End:=.Tables(1).Cell(.Tables(1).Rows.Count, 3).Range.End)
myCells.Select
End With
Now, when I copy this selection manually and paste it into notepad, I get exactly what I want:
Title
Composer
Title
Composer
etc.
However, I want to write this selection automatically into a text file. When I try to do this, all content is stuffed in one line of text and little squares (paragraph signs?) pop up everywhere.
How would be I be able to get the result of the manual copying, using VBA?
Try this
Sub Allmusic()
Dim filesize As Integer
Dim FlName As String, tempStr As String
Dim i As Long
Dim MyAr() As String
'~~> Name of Output File
FlName = "C:\Sample.Txt"
'~~> Get a free file handle
filesize = FreeFile()
'~~> Open your file
Open FlName For Output As #filesize
With ActiveDocument
For i = 2 To .Tables(1).Rows.Count
'~~> THIS LINE WILL NOT REFLECT CORRECTLY IN THE BROWSER
'~~> PLEASE REFER TO THE SCREENSHOT OR THE ATTACHED FILE
tempStr = Replace(.Tables(1).Cell(i, 3).Range.Text, "", "")
If InStr(1, tempStr, Chr(13)) Then
MyAr = Split(tempStr, Chr(13))
Print #filesize, MyAr(0)
Print #filesize, MyAr(1)
Else
Print #filesize, tempStr
End If
Print #filesize, ""
Next i
End With
Close #filesize
End Sub
SNAPSHOT
SAMPLE FILE
http://sdrv.ms/Mo7Xel
Download the file and run the procedure Sub Allmusic()
OUTPUT