I am extremely green when it comes to VBA. However I need a VBA script inside an existing workbook that will create a csv from a specific range of cells on a separate worksheet in the workbook. I have a button that I created on sheet 1 that when clicked grabs the data on sheet 3. I also need the data formatted in the same manor in which it is displayed on the sheet3. The range of cells on sheet 3 is A1:E12. The biggest issue I am having is with the formatting. I have attached an example of the format of the data on sheet 3:ExcelSheet3Data
Sub InfoBlox()
Host = Sheet1.Range("C4").Value
Dim rCell As Range
Dim rRow As Range
Dim vaColPad As Variant
Dim i As Long
Dim sOutput As String
Dim sFname As String, lFnum As Long
Const sDELIM As String = ";"
'Required width of columns
vaColPad = Array(0, 0, 6, 0, 4)
i = LBound(vaColPad)
'Open a text file to write
sFname = "c:\fcbnoc" & "\" & Host & "-INFOBLOX-CONFIG" & ".csv"
lFnum = FreeFile
Open sFname For Output As lFnum
'Loop through the rows
For Each rRow In Sheet3.UsedRange.Rows
'Loop through the cells in the rows
For Each rCell In rRow.Cells
'If the cell value is less than required, then pad
'it with zeros, else just use the cell value
'If Len(rCell.Value) < vaColPad(i) Then
'sOutput = sOutput & Application.Rept(0, _
'vaColPad(i) & Len(rCell.Value)) & rCell.Value & sDELIM
'Else
sOutput = sOutput & rCell.Value
'& sDELIM (this value generates an extra delimiter at the end of every line).
'End If
'i = i + 1
Next rCell
'remove the last comma
sOutput = Left(sOutput, Len(sOutput))
'write to the file and reinitialize the variables
Print #lFnum, sOutput
sOutput = ""
i = LBound(vaColPad)
Next rRow
'Close the file
Close lFnum
End Sub
I am sure I am making this more difficult than I need, but appreciate any help that is provided.
Related
new to VBA but trying to make a macro for the following:
I want the macro to open a text file (location provided in cell A2
with file name in cell B2), to find the text (provided in cell C2),
replace the text with new text that is provided in cell D2, and then save and close the text file.
Then, it should open a text file (location provided in cell A3 with
file name in cell B3), to find the text (provided in cell C3), replace the text with new text that is provided in cell D3, and then save and close the text file.
Repeating until all the files provided in the spreadsheet have been
updated.
Thanks for you help!
Example of spreadsheet:
spreadsheet
Note that I'd like to be able to find and replace text that don't necessarily have to have the same number of characters as the original text.
Attempt so far is below. When running debug, the strText is correct when hovered over, then when it passses the Get #i, , strText step, it changes to be the header of the text file that is I am trying to update.
Sub Replace_Text()
Dim src As String, fl As String
Dim strFile As String
Dim i As Integer
Dim x As Integer
Dim strText As String
Dim lngMyRow As Long
Dim lngLastRow As Long
i = FreeFile
Application.ScreenUpdating = False
lngLastRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
For lngLastRow = 2 To lngLastRow
x = 2
'Source directory
src = Range("A" & x)
'File name
strFile = Range("B" & x)
With CreateObject("vbscript.regexp")
.Global = True
Open src & "\" & strFile For Binary Access Read Write As #i
strText = Space(LOF(i))
Get #i, , strText
For Each cell In Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
.Pattern = Replace(Replace(Replace(Replace(cell.Value, "?", "\?"), "*", "\*"), "+", "\+"), ".", "\.")
strText = .Replace(strText, cell.Offset(, 1).Value)
Next cell
Put #i, , strText
Close #i
End With
i = i + 1
Next lngLastRow
MsgBox "done"
Application.ScreenUpdating = True
End Sub
trying to turn an excel worksheet into a csv with only the data I need. Basically I need to only export columns that contain data. I'm pretty new to using vba macros. I've made a worksheet with cells linked to comboboxes for the first row in columns A:AF. The problem is that it seems these combobox-linked cells are treated as data when I either try to directly save the worksheet as a csv or export using the macro further below.
Example of first (column heading/variable name) line and then an example first row of one observation that I would ideally see in the exported csv:
Author,Year,Yield,Treatment
Smith,1999,2.6,notill
Where the Author...Treatment line originally came from selections in validation list restricted cells linked to comboboxes and the Smith...notill observation is something I paste in. Example of what I see instead:
Author,Year,Yield,Treatment,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
Smith,1999,2.6,notill,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
And then all the rows of observations below that are the same number of columns across.
This creates problems since I now have new variables that mess up merges if I do getnames in SAS. I can't specify the columns, since every time this is created and then exported, there are different numbers of columns. There are ways to deal with this if the columns you want are known, eg this answer . But I want to be able to able to say either ideally "copy only the columns that aren't empty," or maybe "copy only the columns with one of the following specific text in the first row" since A2:AF2 can only contain one of 32 certain things if they're not empty.
Here is the the code I've got that copies all these blank columns to a new workbook and saves that.
Sub CopyToCSV()
Dim MyPath As String
Dim MyFileName As String
'The path and file names:
MyPath = "C:\Users\Data\TxY\"
MyFileName = "TxY_" & Sheets("ValidationHeadings").Range("D3").Value & "_" & Format(Date, "ddmmyy")
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
'Makes sure the filename ends with ".csv"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
'Copies the sheet to a new workbook:
Sheets("TxYdata").Copy
'The new workbook becomes Activeworkbook:
With ActiveWorkbook
'Saves the new workbook to given folder / filename:
.SaveAs Filename:= _
MyPath & MyFileName, _
FileFormat:=xlCSV, _
CreateBackup:=False
'Closes the file
.Close False
End With
End Sub
I know this has to be pretty simple (a column with nothing in it should stand out somehow, right?) but I searched for like 4 hours yesterday on how to do this. I would rather not demarcate the empty columns somehow in each worksheet that I am turning into a csv. Is there something I can add to
Sheets("TxYdata").Copy
to get it to only copy columns where I actually entered data, when I don't have a consistent number of columns in every sheet? Or something else that gets the job done.
Thanks so much!
Test this code.
Sub TransToCSV()
Dim vDB, vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strTxt As String
Dim rngDB As Range, Ws As Worksheet
Dim MyPath As String, myFileName As String
Dim FullName As String
MyPath = "C:\Users\Data\TxY\"
myFileName = "TxY_" & Sheets("ValidationHeadings").Range("D3").Value & "_" & Format(Date, "ddmmyy")
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
If Not Right(myFileName, 4) = ".csv" Then myFileName = myFileName & ".csv"
FullName = MyPath & myFileName
Set Ws = Sheets("TxYdata")
Set objStream = CreateObject("ADODB.Stream")
With Ws
Set rngDB = .Range("a1", "d" & .Range("a" & Rows.Count).End(xlUp).Row)
'Set rngDB = .Range("a1").CurrentRegion <~~ Else use this codle
End With
vDB = rngDB
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, ",")
Next i
strTxt = Join(vTxt, vbCrLf)
With objStream
'.Charset = "utf-8"
.Open
.WriteText strTxt
.SaveToFile FullName, 2
.Close
End With
Set objStream = Nothing
End Sub
You can approach this in different ways. Here is what I would do. Add a new sheet to your workbook. Have a FOR loop in your function to go through all columns in your sheet. For each column, you can use something like this to check if it holds any data:
iDataCount = Application.WorksheetFunction.CountIf(<worksheet object>.Range(<your column i.e. `"F:F"`>), "<>" & "")
If iDataCount is 0 then you know the column is empty. If its anything other than 0, copy it in the new sheet. Once you have complete the FOR loop, copy the new sheet into the .csv file. Finally remove the new sheet from your workbook (or you can leave it there. If you do, you just have to clear it before you run the process next time .. which can be done via the code as well)
I'm just new in using excel vba macro. I am trying to create text file and use the cell values as name of individual text file. At the first place the value contains character and those character will be replaced. the only value will remain are all numbers. That function is working well. My problem is once I execute the create button, the program will create an extra text file which name is base on empty cell and no any input "D" as input in the text file. What I want is to create a text file without that extra text file created. below is my excel format and the code.
I have 3 column use as below:
LOG DATA INPUT BLOCK NAME
5687 D ASD
5689 D
5690 D
5692 D
5691 D
5688 D
4635 D
Correct result will create four text file:
abc-5687.req
abc-5689.req
abc-5690.req
abc-5692.req
Result with extra text file consider as wrong see below:
abc-.req <-- extra text file created
abc-5687.req
abc-5689.req
abc-5690.req
abc-5692.req
my code:
Private Sub CREATE_REQ_Click()
Dim myDataSheet As Worksheet
Dim myReplaceSheet As Worksheet
Dim myLastRow As Long
Dim myRow As Long
Dim myFind As String
Dim myReplace1 As String
Dim myReplace2 As String
Dim sExportFolder, sFN
Dim rArticleName As Range
Dim rDisclaimer As Range
Dim oSh As Worksheet
Dim oFS As Object
Dim oTxt As Object
' Specify name of Data sheet
Set myDataSheet = Sheets("Sheet1")
' Specify name of Sheet with list of replacements
Set myReplaceSheet = Sheets("Sheet2")
' Assuming list of replacement start in column A on row 2, find last entry in list
myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
' Loop through all list of replacments
For myRow = 2 To myLastRow
' Get find and replace values (from columns A and B)
myFind = myReplaceSheet.Cells(myRow, "A")
myReplace1 = myReplaceSheet.Cells(myRow, "B")
' Start at top of data sheet and do replacements
myDataSheet.Activate
Range("A2").Select
' Ignore errors that result from finding no matches
On Error Resume Next
' Do all replacements on column A of data sheet
Columns("A:A").Replace What:=myFind, Replacement:=myReplace1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next myRow
sExportFolder = "D:\TEST\REQ_FILES_CREATED_HERE"
Set oSh = Sheet1
Set oFS = CreateObject("Scripting.Filesystemobject")
For Each rArticleName In oSh.UsedRange.Columns("A").Cells
Set rDisclaimer = rArticleName.Offset(, 1)
If rArticleName = "" & "LOG DATA" Then
oTxt = False
Else
'Add .txt to the article name as a file name
sFN = "-" & rArticleName.Value & ".req"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True)
oTxt.Write rDisclaimer.Value
oTxt.Close
End If
Next
'Reset error checking
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "Replacements complete! "
End Sub
For Each rArticleName In oSh.UsedRange.Columns("A").Cells
Set rDisclaimer = rArticleName.Offset(, 1)
If Not(rArticleName = "" Or rArticleName = "LOG DATA") Then
'Add .txt to the article name as a file name
sFN = "-" & rArticleName.Value & ".req"
Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True)
oTxt.Write rDisclaimer.Value
oTxt.Close
End If
Next
Pretty close to a one line fix. You just need to fix the If. Once that's right you don't need the Else.
I am trying to use some Parsing i was able to tweak a little. If I use it in straight VBA in excel, it works fine. However, when I use the same code as a module in VB.NET I get the error in the title on the line of code
ws.Range(vTitles).AutoFilter()
(duh!) I am not sure what is going wrong in the conversion, since I am not a hardcore VB.Net programmer, so I am doing a lot of googling, but not finding much that works. Any ideas on how this could be fixed or do I have to abandon the idea of using this snippet in VB.Net?
Here is the code I am using:
'turned strict off or autofilter per http://www.pcreview.co.uk/threads/autofilter-method-of-range-class-failed.3994483/
Option Strict Off
Imports xl = Microsoft.Office.Interop.Excel
Module ParseItems
Public Sub ParseItems(ByRef fileName As String)
'Jerry Beaucaire (4/22/2010)
'Based on selected column, data is filtered to individual workbooks are named for the value plus today's date
Dim wb As xl.Workbook
Dim xlApp As xl.Application
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As xl.Worksheet, MyArr As Object, vTitles As String, SvPath As String
'Set new application and make wb visible
xlApp = New xl.Application
xlApp.Visible = True
'open workbook
wb = xlApp.Workbooks.Open(fileName)
'Sheet with data in it
ws = wb.Sheets("Original Data")
'Path to save files into, remember the final "\"
SvPath = "G:\MC VBA test\"
'Range where titles are across top of data, as string, data MUST have titles in this row, edit to suit your titles locale
vTitles = "A1:L1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = xlApp.InputBox("What column to split data by? " & vbLf & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xl.XlDirection.xlUp).Row
'Speed up macro execution
'Application.ScreenUpdating = False
'Get a temporary list of unique values from key column
ws.Columns(vCol).AdvancedFilter(Action:=xl.XlFilterAction.xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True)
'Sort the temporary list
ws.Columns("EE:EE").Sort(Key1:=ws.Range("EE2"), Order1:=xl.XlSortOrder.xlAscending, Header:=xl.XlYesNoGuess.xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xl.Constants.xlTopToBottom, DataOption1:=xl.XlSortDataOption.xlSortNormal)
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = xlApp.WorksheetFunction.Transpose(ws.Range("EE2:EE" & ws.Rows.Count).SpecialCells(xl.XlCellType.xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear()
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter()
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter(Field:=vCol, Criteria1:=MyArr(Itm))
ws.Range("A1:A" & LR).EntireRow.Copy()
xlApp.Workbooks.Add()
ws.Range("A1").PasteSpecial(xl.XlPasteType.xlPasteAll)
ws.Cells.Columns.AutoFit()
MyCount = MyCount + ws.Range("A" & ws.Rows.Count).End(xl.XlDirection.xlUp).Row - 1
xlApp.ActiveWorkbook.SaveAs(SvPath & MyArr(Itm), xl.XlFileFormat.xlWorkbookNormal)
'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51 'use for Excel 2007+
xlApp.ActiveWorkbook.Close(False)
ws.Range(vTitles).AutoFilter(Field:=vCol)
Next Itm
'Cleanup
ws.AutoFilterMode = False
MsgBox("Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!")
xlApp.Application.ScreenUpdating = True
End Sub
End Module
Looks like you need to specify at least one optional parameter. Try this:
ws.Range(vTitles).AutoFilter(Field:=1)
I realize this was closed years ago, but I recently ran into this problem and wanted to add to the solution.
This seems to only work when specifically using the first optional Field parameter. I attempted this fix using the optional VisibleDropDown parameter and still got this error.
ws.Range["A1"].AutoFilter(VisibleDropDown: true); Gives error
ws.Range["A1"].AutoFilter(Field: 1); No error
I would like to loop through an Excel worksheet and to store the values based on a unique ID in a text file.
I am having trouble with the loop and I have done research on it with no luck and my current nested loop continually overflows. Instead of updating the corresponding cell when the control variable is modified, it continues to store the initial Index value for all 32767 iterations.
Please can someone explain why this is happening, and provide a way of correcting it?.
Sub SortLetr_Code()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Value of cell for example B1 starts out as X
Dim x As Integer
Dim y As Integer
x = 2
y = 2
'Cell References
Dim rwCounter As Range
Dim rwCorresponding As Range
Dim rwIndexValue As Range
Dim rwIndexEnd As Range
Dim rwIndexStore As Range
'Variables for files that will be created
Dim FilePath As String
Dim Filename As String
Dim Filetype As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
Filetype = ".dat"
'Use Cell method for Loop
rwIndex = Cells(x, "B").Value
Set rwCounter = Range("B" & x)
'Use Range method for string manipulation
Set rwCorresponding = Range("A" & x)
Set rwIndexValue = Range("B" & y)
Set rwIndexStore = Range("B" & x)
Set rwIndexEnd = Range("B:B").End(xlUp)
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
For Each rwIndexStore In rwIndexEnd.Cells
'Get Substring of cell value in BX for the file name
Do Until IsEmpty(rwCounter)
Filename = Mid$(rwIndexValue, 7, 5)
Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype)
'Create the file
FileWrite.Write (rwCorresponding & vbCrLf)
Do
'Add values to the textfile
x = x + 1
FileWrite.Write (rwCorresponding & vbCrLf)
Loop While rwCounter.Value Like rwIndexValue.Value
'Close this file
FileWrite.Close
y = x
Loop
Next rwIndexStore
End Sub
I don't see a place you are setting rwCounter inside the loop.
It looks like it would stay on range("B2") and x would just continue to increase until it hits an error, either at the limit of integer or long.
add Set rwCounter = Range("B" & x) somewhere inside your loop to increment it
This is the solution.
Sub GURMAIL_File()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Variables that store cell number
Dim Corresponding As Integer
Dim Index As Integer
Dim Counter As Integer
Corresponding = 2
Index = 2
Counter = 2
'Cell References
Dim rwIndexValue As Range
'Variables for files that will be created
Dim l_objFso As Object
Dim FilePath As String
Dim Total As String
Dim Filename As String
Dim Filetype As String
Dim FolderName As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
'Name of the folder to be created
FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\"
'Folder path
Total = FilePath & FolderName
'File Extension
Filetype = ".dat"
'Object that creates the folder
Set l_objFso = CreateObject("Scripting.FileSystemObject")
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
'Get Substring of letter code in order to name the file. End this loop once ID field is null.
Do While Len(Range("A" & Corresponding)) > 0
'Create the directory if it does not exist
If Not l_objFso.FolderExists(Total) Then
l_objFso.CreateFolder (Total)
End If
'Refence to cell containing a letter code
Set rwIndexValue = Range("B" & Index)
'Substring of that letter code
Filename = Mid$(rwIndexValue, 7, 5)
'Create the file using the substring and store it in the proper location
Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True)
'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored.
Do While Range("B" & Index) Like Range("B" & Counter)
'Add each line to the text file.
FileWrite.WriteLine (Range("A" & Corresponding))
'Incrementer variables that allow you to exit the loop
'if you have reached the last value of the current letter code.
Corresponding = Corresponding + 1
Counter = Counter + 1
Loop
'Close the file you were writing to
FileWrite.Close
'Make sure that Index value is updated to the next letter code
Index = Counter
'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value).
Set rwIndexValue = Range("B" & Index)
Loop
End Sub