I'm using the following code to export rows to individual text files:
Sub export_Test()
Dim firstRow As Integer, lastRow As Integer, fileName As String
Dim myRow As Integer, myStr As String
firstRow = 10
lastRow = 29
For myRow = firstRow To lastRow
fileName = "C:\mallet\test\" & Cells(myRow, 1) & ".txt"
Open fileName For Append As #1
myStr = Cells(myRow, 2).Value
Print #1, myStr
Close #1
Next
End Sub
The problem is that this code is for a specific number of rows. I want to use this code for different data samples, so the number of rows in the excel file will vary and could number in the thousands. I need the lastRow variable to be set to an infinite number and exit the For Loop when it hits an empty row.
This code will start in row 10 and run until it finds a blank cell in the second column. Note that I also shortened your code a bit (though it still does the same writing to a file):
Sub export_Test()
Dim myRow As Long
myRow = 10
While Cells(myRow, 2).Value <> ""
Open "C:\mallet\test\" & Cells(myRow, 1) & ".txt" For Append As #1
Print #1, Cells(myRow, 2).Value
Close #1
myRow = myRow + 1
Wend
End Sub
This is code from a project of mine that does exactly what you want - end with a blank value
Sub export_Test()
Dim firstRow As Integer, lastRow As Integer, fileName As String
Dim myRow As Integer, myStr As String
firstRow = 10
myRow = firstRow
' Seed initial value
Cells(myRow, 1).Select
' Keep going until a blank cell is found
While Trim(ActiveCell.Value) <> ""
fileName = "C:\mallet\test\" & ActiveCell.Value & ".txt"
Open fileName For Append As #1
myStr = Cells(myRow, 2).Value
Print #1, myStr
Close #1
' Get the next value
myRow = myRow + 1
Cells(myRow, NameCol).Select
Wend
End Sub
Related
I get a mismatch error in this line :
row_str = Join(cell_rng, Chr(10))
Thank you. I am intermediate.
I attached a piece of the code below:
Dim last_row As String
Dim last_col As String
Dim office_str As String
Dim lookupVal As String
Dim i As Long
Dim seperate_cells, cell_rng As Range
Dim r As Range
Dim row_str As String
With Contacts
For i = 2 To last_row
Set cell_rng = Rows(i & ":" & i + 1)
For Each r In cell_rng.Rows
seperate_cells = cellsSeparator(r.SpecialCells(xlCellTypeConstants))
If row_str = "" Then
row_str = Join(cell_rng, Chr(10))
Else
row_str = row_str & vbLf & Join(cell_rng, Chr(10))
End If
Next
Debug.Print row_str
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & row_str
Next i
End With
````
Please try the next way. It will place the values of the necessary specific row in the text box, each value separated by " | ":
Sub testSeparatorsBetweenRowCells()
'your existing code...
Dim arr, rngR As Range
For i = 2 To last_row
lookupVal = cells(i, office_str)
' Compare ComboBox with the range from the spreadsheet
If lookupVal = Office_Code Then
Set rngR = rows(i & ":" & i).SpecialCells(xlCellTypeConstants) 'Set a range which will return all cells value in the row, except the empty ones
arr = arrCells(rngR) 'call a function able to make an array from the range set in the above line
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & Join(arr, " | ") 'add the text obtained by joining the array to the next line of existing text
End If
Next i
End Sub
Function arrCells(rng As Range) As Variant
Dim arr, Ar As Range, i As Long, C As Range
ReDim arr(rng.cells.count - 1) 'ReDim the array to be filled as the range cells number.
'- 1, because the array is 0 based...
For Each Ar In rng.Areas 'iterate between the range areas
For Each C In Ar.cells 'iterate between cells of each area
arr(i) = C.value: i = i + 1 'put each cell value in the array
Next
Next
arrCells = arr 'make the function returning the arr
End Function
If the text in the text box still goes on the next line, try making the text box property WordWrap False. If you cannot see all the text, make the textbox wider or decrease its font size.
Please, test it and send some feedback.
Edited:
Please, try understanding the next piece of code, able to deal with copying more rows at once:
Sub testCopyingMoreRows()
Dim sh As Worksheet, i As Long, rng As Range, r As Range, arr, strRow As String
Set sh = ActiveSheet
i = 9
Set rng = sh.rows(i & ":" & i + 1)
'you ca select cells, rows (even not consecutive) and use:
'Set rng = Selection.EntireRow 'just uncomment this code line...
'extract rows and paste their contents (exept the empty cells) in Imediate Window
For Each r In rng.rows
arr = arrCells(r.SpecialCells(xlCellTypeConstants))
If strRow = "" Then
strRow = Join(arr, " | ")
Else
strRow = strRow & vbLf & Join(arr, " | ")
End If
Next
Debug.Print strRow
'instead returning in Imediate Window, you can do it in your text box (uncomment the next line):
'Client_Finder.result.Text = Client_Finder.result.Text & vbLf & strRow
End Sub
The code uses the same function arrCells...
What I need help on is to copy the previous cells text into the cell below it and add the letter A at the end of it i.e. before VP0007 after VP0007A. This should continue until all the blank cells have been incremented and it reaches the next VP0008.
Please see the images. I apologise if I am not too clear.
Before: After:
Right now I have the following code:
ActiveCell.Offset(1, 0).Select
Letter = "A"
Letters = Chr(Asc(Letter) + 1)
Number = ActiveCell.Offset(-1, 0).Value
If ActiveCell.Value = Number & Letter _ Then
ActiveCell.Offset(1, 0).Select.Value Number & Number
Else
ActiveCell.Value = Number & Letters
End If
Loop Until ActiveCell.Offset(1, 0).Value <> ""
Try this short sub procedure.
Sub fillSubseries()
Dim i As Long, a As Long, str As String
With Worksheets("sheet4")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If IsEmpty(.Cells(i, "A")) Then
.Cells(i, "A") = str & Chr(a)
a = a + 1
Else
a = 65
str = .Cells(i, "A").Value2
End If
Next i
End With
End Sub
Try using the below code
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Letter = "A"
For iLoop = 2 To LastRow
If ActiveSheet.Range("A" & iLoop) = "" Then
iValue = ActiveSheet.Range("A" & iLoop - 1)
iiLoop = iLoop
Do
If ActiveSheet.Range("A" & iiLoop) = "" Then
ActiveSheet.Range("A" & iiLoop) = iValue & Letter
Letter = Chr(Asc(Letter) + 1)
Else
Letter = "A"
Exit Do
End If
iiLoop = iiLoop + 1
Loop
iLoop = iiLoop - 1
End If
Next
This code should handle cases where you have more than 26 blank rows and increment past the letter "Z".
Sub FillBlanks()
Dim lastRow As Long, cnt As Long, i As Long
Dim prevItem As String
Dim ws As Worksheet
Set ws = ActiveSheet
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
prevItem = ws.Cells(2, 1).Value
cnt = 0
For i = 2 To lastRow
If ws.Cells(i, 1) = "" Then
cnt = cnt + 1
ws.Cells(i, 1).Value = prevItem & Split(Cells(1, cnt).Address(True, False), "$")(0)
Else
prevItem = ws.Cells(i, 1)
cnt = 0
End If
Next i
End Sub
Alternate:
Sub tgr()
Dim ws As Worksheet
Dim aData As Variant
Dim sTemp As String
Dim sLetter As String
Dim i As Long, j As Long
Set ws = ActiveWorkbook.ActiveSheet
With ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
aData = .Value
End With
For i = LBound(aData, 1) To UBound(aData, 1)
If Len(Trim(aData(i, 1))) > 0 Then
sTemp = Trim(aData(i, 1))
j = 0
Else
j = j + 1
sLetter = Replace(ws.Cells(1, j).Address(0, 0), 1, vbNullString)
aData(i, 1) = sTemp & sLetter
End If
Next i
ws.Range("A2").Resize(UBound(aData, 1)).Value = aData
End Sub
If you need a pure formula solution, you may try below steps (The first row of your data should be A2, not A1):
First we need a dummy column in order to fill in the blank rows. Use below formula on B2 and copy it down through the last row of column A:
=IF(A2<>"",A2,B1)
Then we will create the final values on column C. Add below formula to C2 and copy down:
=IF(A2<>"",A2,IF(ISNUMBER(VALUE(RIGHT(C1,1)))=TRUE,C1&"A",B2&CHAR(CODE(RIGHT(C1,1))+1)))
Basically we first filled in the blank rows with repeating values on column B. Then copied Col:A value to Col:C if Col:A is not blank. If Col:A is blank and upper row (Col:C) value's last character is numeric we add "A" to that value. If the last character is a letter than we concatenate the next letter with Col:B value.
You should have something like below, when everything is OK:
I have the following Excel cells:
D001
D002
D003
345
(In the same cell)
I need to add a string of text after every line on the same cell, like this:
D001 First Text
D0002 Second Text
D003 Third Text
345 Fouth Text
I found a code which allows me to count how many lines there are on the same cell, but I dont find any way of using it to write after the text on each of those lines:
Public Sub CountLines()
Dim H1 As Double
Dim H2 As Double
Dim row As Long
row = 1
While Cells(row, 1).Value <> ""
With Cells(row, 1)
.WrapText = False
H1 = .height
.WrapText = True
H2 = .height
.Offset(0, 1).Value = H2 / H1
End With
row = row + 1
Wend
End Sub
I guess the right way of doing it is by using a For to write text before any change of line he finds (Ch(10)) on VBA, but i havent been able to make it work
Thanks for the help.
Adding Text To Count Line Breaks
This code will loop through all cells with any value in Column A.
I have recreated your data set in my Excel:
The code will break up each line, add which line it is, and move on to the next:
Below is the code:
Sub AddText()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim myCell As Variant, myRange As Range, tempArr() As String
Dim i As Integer
Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
For Each myCell In myRange
tempArr = Split(myCell, Chr(10))
myCell.Value = ""
For i = 0 To UBound(tempArr)
tempArr(i) = tempArr(i) & " text " & i
If i = UBound(tempArr) Then
myCell.Value = myCell.Value & tempArr(i)
Else: myCell.Value = myCell.Value & tempArr(i) & Chr(10)
End If
Next i
Next myCell
End Sub
If you want it to count from base 1 instead of base 0, change the lines myCell.Value = myCell.Value & tempArr(i) (and the following one in the If statement) to myCell.Value = myCell.Value & tempArr(i) + 1
I should mention again that this is already set up for a dynamic range in Column A. Meaning if you add more data formatted the same way in A2, the code will apply itself to that as well, all the way to the last set of data in column A.
Dim arr() As String
Dim arr2() As String
arr = Split(yourCell, char(10))
arr2 = Split("first, second, third", "," )
For i = 1 To UBound(arr)
debug. print arr(i) + arr2(i)
next i
after rebuilding the new string the new string assign it back to the cell
This will only place (random) text after each line in the cell. But it gives you a place to start.
Option Explicit
Public Sub RePrint()
Dim MyRange As Range
Dim MyArray As Variant
Dim i As Long
Set MyRange = Range("A1")
MyArray = Split(MyRange, Chr(10))
For i = LBound(MyArray) To UBound(MyArray)
MyArray(i) = MyArray(i) & " Text" & i
Next i
MyRange = Join(MyArray, Chr(10))
End Sub
you could use this function:
Function AddText(rng As Range, textsArr As Variant) As String
Dim nTexts As Long, nLines As Long, iLine As Long
Dim linesArr As Variant
nTexts = UBound(textsArr) - LBound(textsArr) + 1
With rng
linesArr = Split(.Value, vbLf)
nLines = UBound(linesArr) - LBound(linesArr) + 1
If nTexts < nLines Then nLines = nTexts
For iLine = 1 To nLines
linesArr(LBound(linesArr) - 1 + iLine) = linesArr(LBound(linesArr) - 1 + iLine) & " " & textsArr(LBound(textsArr) - 1 + iLine)
Next iLine
AddText = Join(linesArr, vbLf)
End With
End Function
to be exploited as follows
Option Explicit
Sub main()
Dim cell As Range
Dim additionalTexts As Variant
additionalTexts = Array("First Text", "Second Text", "Third Text", "Fourth Text") '<--| set your array of additional text, each element index corresponding to to be processed cell content line
With Worksheets("ADDTEXT") '<--| reference your relevant worksheet (change "ADDTEXT" to your actual relevant worksheet name)
For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column "A" cells form row 1 down to last not empty row
cell.Value = AddText(cell, additionalTexts) '<--| process
Next cell
End With
End Sub
This will but in the text "First Line", "Second Line"... after each line. The way it is set up now uses the value in A1 and replaces the value in A1. It is ideal for cells with 4 lines or less, but it will work with more.
Sub appendCharacters()
Dim lines() As String
Dim text As String
lines = Split(Range("A1"), Chr(10))
Range("A1").Value = ""
For i = LBound(lines) To UBound(lines)
Select Case i
Case 0
text = " First Line"
Case 1
text = " Second Line"
Case 2
text = " Third Line"
Case 3
text = " Fourth Line"
Case Else
text = " Another Line"
End Select
lines(i) = lines(i) + text
Range("A1").Value = Range("A1").Value + lines(i)
If i <> UBound(lines) Then
Range("A1").Value = Range("A1").Value + vbCrLf
End If
Next i
End Sub
I am using the code below to generate the single file for selected range and considering the first cell in the selected range as file name. Please find the image below for more details[This image shows the selected range,Consider K column(Firstline) and N Column( Lastline) to be in one file and other set of 1st and last line in other file ]this image shows the print file for a single file this is the way m currently using for generating files.I need to create more 30k files so please help me to create more files in single click considering the first and last line as header and footer for the file
Private Sub CommandButton1_Click()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer, path As String, filename, filename2 As String
path = "D:\Watchlist-Files\"
filename = Selection.Cells(1, 1).Value
filename2 = Left(Mid(filename, 32, 99), Len(Mid(filename, 32, 99)) - 2)
myFile = path & filename2
Set rng = Selection
Open myFile For Output As #1
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
Else
Print #1, cellValue,
End If
Next j
Next i
Close #1
End Sub
The code below is using a Loop that scans rows in a range that consists of Columns K:N (according to your attached screen-shots).
Assumptions made: your FirstLine is in Column K, and it's the marker of the start position of copying the first cell in the first row.
Your LastLine is in Column N, and it's the marker of the last cell to copy, this is why I am closing the file once it is found.
Edit 1: added a Msgbox to allow the user selection of exporting the entire range or not. In case the user selected NO, then a second InputBox appears that allows the user to enter manually the last row number to export.
Option Explicit
Public Sub CommandButton1_Click()
Dim myFile As String
Dim rng As Range
Dim cellValue As Variant
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim path As String
Dim filename As String
Dim response As Boolean
path = "D:\Watchlist-Files\"
response = MsgBox("Do you want to Export the entire Range ? ", vbYesNo)
' Export the entire Range
If response = vbYes Then
LastRow = Cells(Rows.Count, "N").End(xlUp).Row
Else ' enter in the inputbox the last row number you want to export
LastRow = InputBox("Enter Last Row Number you wsnt to Export")
End If
Set rng = Range("K2:N" & LastRow)
For i = 2 To LastRow
' Column K holds the file name
If Cells(i, 11) <> "" Then
filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)
myFile = path & filename
Open myFile For Output As #1
End If
For j = 1 To rng.Columns.Count
cellValue = Cells(i, 10 + j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
' found LastLine >> close the file
If Not cellValue = "" Then
Close #1
End If
Else
Print #1, cellValue,
End If
Next j
Next i
End Sub
Edit 2: Added new code below (to keep the first option valid). The user needs to confirm that every selection he makes start and ends with FirstLine and LastLine , there is no error handling.
Option Explicit Section
Option Explicit
Dim filename As String
Dim path As String
Dim myFile As String
Dim rng As Range
Dim j As Long
Public Sub CommandButton1_Click
Public Sub CommandButton1_Click()
Dim lastRow As Long
Dim Sel_Range As Long
Dim response As Boolean
Dim rowStart() As Long
Dim rowFinish() As Long
path = "D:\Watchlist-Files\"
response = MsgBox("Do you want to Export only the Selected Range ? ", vbYesNo)
If response = True Then
Set rng = Selection
ReDim rowStart(1 To Selection.Areas.Count)
ReDim rowFinish(1 To Selection.Areas.Count)
For Sel_Range = 1 To Selection.Areas.Count
rowStart(Sel_Range) = Selection.Areas(Sel_Range).Row
rowFinish(Sel_Range) = Selection.Areas(Sel_Range).Row + Selection.Areas(Sel_Range).Rows.Count - 1
Call CreateTextFiles(rowStart(Sel_Range), rowFinish(Sel_Range))
Next Sel_Range
Else ' export the entire Range in Columns K:N
lastRow = Cells(Rows.Count, "N").End(xlUp).Row
Set rng = Range("K2:N" & lastRow)
Call CreateTextFiles(2, lastRow)
End If
Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long) - new routine to allow handling of multiple Ranges selection
Sub CreateTextFiles(Sel_StartRow As Long, Sel_FinishRow As Long)
Dim i As Long
Dim cellValue As Variant
For i = Sel_StartRow To Sel_FinishRow
' Column K holds the file name
If Cells(i, 11) <> "" Then
filename = Left(Mid(Cells(i, 11).Value, 32, 99), Len(Mid(Cells(i, 11).Value, 32, 99)) - 2)
myFile = path & filename
Open myFile For Output As #1
End If
For j = 1 To rng.Columns.Count
cellValue = Cells(i, 10 + j).Value
If j = rng.Columns.Count Then
Print #1, cellValue
' found LastLine >> close the file
If Not cellValue = "" Then
Close #1
End If
Else
Print #1, cellValue,
End If
Next j
Next i
End Sub
I am currently using this code(from a fellow user here) to find every cell in column b1 and to find the ones that contain a ";" something like "hello;goodbye". The code will split the cell at the ";" and place "goodbye" directly beneath "hello;" on an entirely new row..
What I need now is this... if a cell contains multiple ";" (ie "hello;goodbye;yo;hi;hey") it will split at EACH ";" not just the first and then move each to a new row directly beneath the other...
What changes do I need to make?
Dim r1 As Range, r2 As Range
Dim saItem() As String
For Each r1 In ActiveSheet.Range("B1", Cells(Application.Rows.Count, 2).End(xlUp))
If InStr(1, r1.Value2, ";") > 0 Then
saItem = Split(r1.Value2, ";")
r1 = Trim$(saItem(0)) & ";"
r1.Offset(1).EntireRow.Insert (xlDown)
r1.Offset(1) = Trim$(saItem(1))
End If
Next r1
I know it's close to what you have, but I wanted to suggest you use Application.ScreenUpdating. This will save considerable time, especially when inserting/deleting rows in Excel. I also wanted to suggest you change the variable names to somehting a little more meaningful.
Sub SplitCells()
Application.ScreenUpdating = False
Dim strings() As String
Dim i As Long
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If InStr(Cells(i, 2).Value, ";") <> 0 Then
strings = Split(Cells(i, 2).Value, ";")
Rows(i + 1 & ":" & i + UBound(strings)).Insert
Cells(i, 2).Resize(UBound(strings) + 1).Value = _
WorksheetFunction.Transpose(strings)
End If
Next
Application.ScreenUpdating = True
End Sub
P.S. Smaller alterations is to use "2" instad of "B". If you are using cells() instead of Range(), may as well go all the way :)
I found an answer over at
http://www.excelforum.com/excel-programming/802602-vba-macro-to-split-cells-at-every.html
This is the solution I was given:
Sub tgr()
Dim rindex As Long
Dim saItem() As String
For rindex = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If InStr(Cells(rindex, "B").Value, ";") > 0 Then
saItem = Split(Cells(rindex, "B").Value, ";")
Rows(rindex + 1 & ":" & rindex + UBound(saItem)).Insert
Cells(rindex, "B").Resize(UBound(saItem) + 1).Value = WorksheetFunction.Transpose(saItem)
End If
Next rindex
End Sub