Looping Macro in Excel - vba

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

Related

How to keep leading zeros when opening CSV file in VBA

I have a VBA code that quickly transfer data from CSV files, but unfortunately exclude leading zeros (For example 000123 is converted to 123)
Filename = "c:\text.csv"
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet
Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Temp")
Filename = "c:\text.csv"
Set wbO = Workbooks.Open(Filename)
wbO.Sheets(1).Cells.Copy wsI.Cells
wbO.Close SaveChanges:=False
I have tried to add the following after opening the csv file > Cells.NumberFormat = "#"
Set wbO = Workbooks.Open(Filename)
Cells.NumberFormat = "#"
wbO.Sheets(1).Cells.Copy wsI.Cells
wbO.Close SaveChanges:=False
Unfortunately, it is not working and the problem I see is that once the file opens already is missing the leading zeros
Is it possible to open the file without affecting the leading zeros and show all the data as text to maintain the leading zeros?
Try this way, please:
Sub testOpenWithLZeroTxt()
Dim Filename As String, wbI As Workbook, wbO As Workbook, wsI As Worksheet
Dim arrTXT, nrCol As Long, arr(), i As Long, sep As String, lineSep As String
Dim allTxt As String, txtStr As Object, fileTxt As String, fs As Object, f As Object, ts As Object
Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Temp")
Filename = "c:\text.csv"
fileTxt = Split(Filename, ".")(0) & ".txt" 'create a helper txt file using the csv string content
Set fs = CreateObject("Scripting.FileSystemObject")
allTxt = fs.OpenTextFile(Filename, 1).ReadAll 'reed the csv file content
fs.CreateTextFile fileTxt
Set f = fs.GetFile(fileTxt)
Set ts = f.OpenAsTextStream(2, -2)
ts.write allTxt 'write the csv content in a newly created txt file
ts.Close
'Check the number of text file columns:_______
sep = vbLf ' if not working you can try vbCrLf. It works so on your file
lineSep = "," 'it my be vbTab, ";" etc. It works so on your file
arrTXT = Split(allTxt, sep)
nrCol = UBound(Split(arrTXT(0), lineSep))
'_____________________________________________
ReDim arr(nrCol) 'redim the format array
For i = 0 To nrCol
arr(i) = Array(i + 1, 2) 'fill the format array with variant for TEXT Format!
Next
'open the helper txt file as you need:
Workbooks.OpenText Filename:=fileTxt, origin:=437, startRow:=1, _
DataType:=xlDelimited, Tab:=False, Comma:=True, FieldInfo:=arr()
Set wbO = ActiveWorkbook
'wbO.Sheets(1).cells.Copy wsI.Range("A1") 'copy the content
wbO.Close SaveChanges:=False 'close the file
Kill fileTxt 'kill helper txt file
End Sub
Edited:
I changed the code philosophy. It will firstly read the csv content in a string variable and create a txt file using the obtained string and open it as text, which certainly should work. It will work for any number of columns in the csv file.
The line break in your csv file is unix LF. This corresponds to chr(10).
Since the number of columns in the first row and the number of columns in the next row are inconsistent, a little bias was used. An array was created by doubling the number of columns in the first row.
Sub test()
Dim Ws As Worksheet
Dim Fn As String
Dim Arr As Variant
Fn = "Example.csv"
'Fn = "c:\text.csv"
Set Ws = Sheets("Temp")
Arr = getDatFromCsv(Fn)
With Ws
.Cells.NumberFormat = "#"
.Cells = Empty
.Range("a1").Resize(UBound(Arr, 1) + 1, UBound(Arr, 2) + 1) = Arr
End With
End Sub
Function getDatFromCsv(strFn As String) As Variant
Dim vR() As String
Dim i As Long, r As Long, j As Integer, c As Integer
Dim objStream As Object
Dim strRead As String
Dim vSplit, vRow
Dim s As String
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Charset = "utf-8"
.Open
.LoadFromFile strFn
strRead = .ReadText
.Close
End With
vSplit = Split(strRead, Chr(10)) 'Unix Lf ~~> chr(10)
r = UBound(vSplit)
c = UBound(Split(vSplit(0), ",", , vbTextCompare))
ReDim vR(0 To r, 0 To c * 2)
For i = 0 To r
vRow = Split(vSplit(i), ",", , vbTextCompare)
'If UBound(vRow) = c Then 'if it is empty line, skip it
For j = 0 To UBound(vRow)
vR(i, j) = vRow(j)
Next j
'End If
Next i
getDatFromCsv = vR
Set objStream = Nothing
End Function
Result Image
Use OpenText method instead.
The most important parameter is FieldInfo. You need to pass:
an array containing parse information for individual columns of data. The interpretation depends on the value of DataType. When the data is delimited, this argument is an array of two-element arrays, with each two-element array specifying the conversion options for a particular column. The first element is the column number (1-based), and the second element is one of the XlColumnDataType constants specifying how the column is parsed.
In other words, every column with leading zeros, has to be defined as xlTextFormat.
I'd suggest to record macro. ;) An option to load text data, you'll find under Data tab -> ... -> From text/CSV

How to remove extra empty text file created using vba excel macro wherein its filename is the cell in a sheet?

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.

Saving a MS Word document with consecutive numbering

#PKatona when I tried it in a real setting it overwrote some files. Upon examining the code, I realized it was counting the number of files in the directory and saving as the next number (say 15th file in folder as 'ST14 TC15') instead of saving as the highest next number in the filenames (say there are only 3 files in the directory and the one with the highest ending is 'ST14 TC06' so the next file should be saved as 'ST14 TC07'. I hope that makes sense. But using some of your code I was able to come up with this: however 1) there must be a way to shorten it! 2) it works in Excel (where I made it) but 'Evaluate' line towards the end gives 'Sub or function not defined' error in Word!!
Thanks again
`Sub Largest()
Dim rng As Range
Dim dblMax As Double
Dim var_data(200)
Dim var_numdata(200)
'* - * - *
'to put filenames in a specific directory into an array
Dim MyFile As String
Dim Counter As Long
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
Dim str()
ReDim str(1000)
Dim num()
ReDim num(1000)
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$("C:\HAPPY\SANTA\ELVES\*.docx")
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
MyFile = Dir$
str(Counter) = Mid(DirectoryListArray(Counter), 8, 3)
num(Counter) = Evaluate(str(Counter))
Counter = Counter + 1
Loop
'Reset the size of the array without losing its values
ReDim Preserve DirectoryListArray(Counter - 1)
ReDim Preserve str(Counter - 1)
ReDim Preserve num(Counter - 1)
dblMax = Application.WorksheetFunction.Max(num())
Dim nextFilename As String
nextFilename = "C:\HAPPY\SANTA\ELVES\ST14 HP" + Format((dblMax + 1), "000")+ ".docx"
ActiveDocument.SaveAs Filename:=nextFilename
ActiveDocument.Close
End Sub
This will find the last file sequence:
Dim filename as String
Dim seq as Integer
seq = 1
filename = Dir("C:\HAPPY\SANTA\ELVES\ST14 TC*.docx")
Do While filename <> ""
seq = seq + 1
filename = Dir
Loop
Dim nextFilename as String
nextFilename = "C:\HAPPY\SANTA\ELVES\ST14 TC" + Format(seq, "000") + ".docx"
Add your macro code here...

Can I use variable as sheetname (VBA)

I am a newcomer to VBA. I am trying to copy selected range from different workbooks and pasted to a target workbook with different sheetname correspondingly to the name of source file.
The code as below:
'open file
Sub RstChk()
Dim StrFileName As String
Dim StrFilePath As String
Dim TimeStr As String
Dim Version As Integer
Dim x As Workbook
Dim y As Workbook
Dim PstTgt As String
'define filename as array
Dim FN(10) As String
FN(1) = "CIO Wholesale"
FN(2) = "RMG"
FN(3) = "DCM"
FN(4) = "DivHeadOth"
FN(5) = "Runoff"
FN(6) = "Other Risk Subs"
FN(7) = "FIC"
FN(8) = "Treasury"
FN(9) = "Cash Equities"
FN(10) = "Global Derivatives"
'define file path
StrFilePath = "V:\RISKMIS\PUBLIC\apps\MORNING\RMU 1.5 Report\Consolidated\"
'define TimeStr
TimeStr = Format(Now() - 1, "mm-dd-yyyy")
Set y = Workbooks.Open("H:\Eform\Report_checking.xls")
'applying filename from array using loop
'----------------------------------------------------------------
For i = 1 To 10
'define changing file name with path & loop
For Version = 65 To 68
StrFileName = (StrFilePath & FN(i) & "_" & TimeStr & "_" & Chr(Version) & ".xls")
Set x = Workbooks.Open(StrFileName)
'-------------------------------------------------
If Chr(Version) = "A" Then
PstTgt = "A3"
ElseIf Chr(Version) = "B" Then
PstTgt = "E3"
ElseIf Chr(Version) = "C" Then
PstTgt = "I3"
Else
PstTgt = "M3"
End If
'copy the column and paste to report checking
y.Worksheets(FN(i)).PstTgt.Copy Destination = x.Sheets("Risk Summary").Range ("AA5:AC118")
Application.CutCopyMode = False
x.Close
Next Version
Next i
End Sub
I get error when I try to copy the range from source file (x) to target file (Y).
Run-time error '13', type mismatch
Just can't figure out what went wrong.
Thanks very much for your help.
Dan
You got this error because your variable PstTgt is a string and not a range "type mismatch"
If you look at the documentation of Range.Copy https://msdn.microsoft.com/en-us/library/office/ff837760.aspx
You have two choices :
Make PstTgt a range and referencing directly to the range in your endif
' Redefine PstTgt as a range
dim PstTgt as Range
' set value of PstTgt
If Chr(Version) = "A" Then
set PstTgt = y.Worksheets(FN(i)).Range("A3")
endif
...
' Copy the range where you want
PstTgt.Copy destination:=x.Sheets("Risk Summary").Range("AA5")
You keep your code like that and just correct your copy by adding Range
y.Worksheets(FN(i)).Range(PstTgt).Copy Destination = x.Sheets("Risk Summary").Range("AA5")

copy paste from one file to several files

I would like to copy some cells from one file to several files. In order to do so,the macro will copy the range and open the several files in order to paste the values. I perform a loop in order to open each of the destination files (the begin of the name of each of the ouput file is the same but the extension differs from file to file : it is based on a range of cells called Name). The concatenation doesn't work well.
Thank you so much for your help!!
Sub update()
Application.ScreenUpdating = False
Dim wkbkorigin As Workbook
Dim wkbkdestination As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim i As Integer
Dim j As Integer
Dim nrow As Integer
Dim ncol As Integer
Dim Pathref As String
Dim Name As String
nrow = Range("names").Rows.Count
ncol = Range("Range").Columns.Count
'this is the path to the different files, the begin is the same but the extension will be added in the loop (the extentsion is based on the value in the range Name
Pathref = Range("Pathref").Value & "[yasmine_nouri]"
For i = 1 To nrow
Name = Range("Names").Cells(i, 1).Value
Set wkbkorigin = ActiveWorkbook
'here i set my destination file, the begin is the same but the extension is based on the value in the range Name : this concatenation doesn't work.
Set wkbkdestination = Workbooks.Open([& Pathref & Name & ".xlsb"])
Set originsheet = wkbkorigin.Worksheets("Completed_DS")
Set destsheet = wkbkdestination.Worksheets("sheet1")
originsheet.Range("D4:Q5").Copy
destsheet.Range("A1").PasteSpecial
wkbkdestination.Close SaveChanges:=True
Next i
End Sub
As follows up from comments, OP should change
Pathref = Range("Pathref").Value & "[yasmine_nouri]"
'...
Set wkbkdestination = Workbooks.Open([& Pathref & Name & ".xlsb"])
to
Pathref = Range("Pathref").Value & "yasmine_nouri"
'...
Set wkbkdestination = Workbooks.Open(Pathref & Name & ".xlsb")