Macro for Text to columns - excel

Sub Macro9()
'
' Macro9 Macro
'
'
Selection.TextToColumns Destination := Range("A3"), DataType := xlFixedWidth, _
FieldInfo := Array(Array(0,1),Array(60,1),Array(63,1),Array(68,1),Array(71,1), _
Array(85,1),Array(88,1),Array(93,1),Array(99,1),Array(107,1),Array(111,1),Array _
(120,1),Array(123,1),Array(127,1),Array(130,1),Array(134,1),Array(143,1),Array( _
147,1),Array(157,1),Array(162,1),Array(165,1),Array(170,1),Array(202,1),Array( _
233,1),Array(236,1),Array(238,1),Array(248,1),Array(251,1),Array(260,1),Array( _
265,1),Array(277,1),Array(283,1),Array(287,1),Array(291,1),Array(295,1),Array( _
299,1),Array(302,1),Array(306,1),Array(310,1),Array(322,1),Array(326,1),Array( _
332,1),Array(335,1),Array(338,1),Array(344,1),Array(348,1),Array(356,1),Array( _
360,1),Array(367,1),Array(373,1),Array(375,1),Array(384,1),Array(387,1),Array( _
394,1),Array(398,1),Array(403,1),Array(409,1),Array(413,1),Array(419,1),Array( _
424,1),Array(429,1),Array(432,1),Array(438,1),Array(444,1),Array(449,1),Array( _
454,1),Array(458,1),Array(463,1),Array(468,1),Array(474,1),Array(478,1),Array( _
481,1),Array(484,1),Array(489,1),Array(493,1),Array(524,1),Array(554,1),Array( _
557,1),Array(563,1),Array(565,1),Array(577,1),Array(594,1),Array(613,1),Array( _
616,1),Array(620,1),Array(626,1),Array(629,1),Array(634,1),Array(646,1),Array( _
654,1),Array(659,1),Array(667,1),Array(669,1),Array(675,1),Array(683,1),Array( _
689,1),Array(696,1),Array(699,1),Array(706,1),Array(714,1),Array(717,1),Array( _
721,1),Array(728,1),Array(730,1),Array(743,1),Array(751,1),Array(754,1),Array( _
758,1),Array(767,1),Array(774,1),Array(779,1),Array(787,1),Array(790,1),Array( _
798,1),Array(805,1),Array(808,1),Array(817,1),Array(822,1),Array(826,1),Array( _
835,1),Array(845,1),Array(853,1),Array(857,1),Array(864,1),Array(869,1),Array( _
877,1),Array(881,1),Array(891,1),Array(895,1),Array(903,1),Array(912,1),Array( _
916,1),Array(920,1),Array(927,1),Array(933,1),Array(937,1),Array(941,1),Array( _
End Sub
I have 800 words in cell A3 in sheet input1, i recorded above macro by using function "Text to columns" in Excel 2007 which is giving error "Too many line continuations".
Can someone tell me the exact code please, indeed I want to add all the 800 words in different individual cells as one word in each cell in the same row.


I do not believe it is possible to tell the Macro Recorder to create longer lines so I do not think TextToColumns can be made to record this code for you.
You are using the fixed width option so words are starting at position 0, 60, 63, 68, 71 and so on. The start positions for about 120 words have been have been recorded so, if you wanted to build an array like this, you will have a lot of typing.
You say "words". To me that implies variable length strings separated by spaces. If that is correct, try the code below. It uses function Split to split cell A3 into words by space. These are then spread out along row 4 with any gaps created by double or triple spaces ignored.
Option Explicit
Sub SplitCell()
Dim CellCrnt As Long
Dim InxW As Long
Dim Word() As String
With Worksheets("input1")
Word = Split(.Range("A3"), " ")
CellCrnt = 1
For InxW = LBound(Word) To UBound(Word)
' Any double spaces will cause empty entries in Word.
' Ignore these empty entries
If Word(InxW) <> "" Then
.Cells(4, CellCrnt).Value = Word(InxW)
CellCrnt = CellCrnt + 1
End If
Next
End With
End Sub

Related

Looping Text to Columns Fixed Width on Individual Rows

I am attempting to build a loop that will look at each row in a column of data and split based on the first instance of an " ". I can get this to work on one line but the loop never activates. I tried my best at formatting this code but could not find a tutorial on how to have the commands appear as different colors and whatnot.
Dim num
Dim RowCnt As Integer
Dim x As Integer
ActiveCell.Select ' the cell to split
RowCnt = Range(Selection, Selection.End(xlDown)).Rows.Count 'determines #rows in column to split
With ActiveCell ' with block
For x = 1 To RowCnt ' define # loops
.Offset(, -1).FormulaR1C1 = "=FIND("" "",RC[1],1)" ' determine first " "
num = .Offset(, -1).Value ' assign the number of chars to 'num'
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(num, 1)), TrailingMinusNumbers:=True ' splits once based on 'num'
.Offset(, -1).ClearContents ' clear
.Offset(1, 0).Activate
Next x
End With
End Sub

I was able to cheat the answer. The issue is the Text to Columns always referred to the first cell until the sub ended. My solution was to make the looped code its own sub and call it in a separate subs loop. That way it ends the sub each time before being called again.

Use this code instead (tested: works!)
Sub updated_delimitter()
start_cell = ActiveCell.AddressLocal
n = Range(start_cell, Range(start_cell).End(xlDown)).Rows.Count 'determines #rows in column to split
Application.ScreenUpdating = False
For x = 0 To n - 1 ' define # loops
this_cell = Range(start_cell).Offset(x).AddressLocal
Range(this_cell).Select
word_ = Range(this_cell).Value
split_at = InStr(word_, " ")
Range(this_cell).TextToColumns Destination:=Range(this_cell), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(split_at, 1)), TrailingMinusNumbers:=True ' splits once based on 'num'
Next
Application.ScreenUpdating = True
End Sub
original code had issues with referencing in relation to 'activecell' which you referenced in the text-to-columns section - removed the with statement and no need to insert num when you can simply store it within VB (getting rid of its placements also mean no code required to remove it...
You could achieve the same in 3 lines of code♦ (w/ for loop) using the following:
Sub test2()
'Range("d2").Select
With Selection
.Offset(, 3).Formula2R1C1 = _
"=LET(x_,RC[-3]:OFFSET(RC[-3],MATCH(0,IFERROR(SEARCH("""",RC[-3]:OFFSET(RC[-3],ROWS(C[-3])-ROWS(RC[-3])-1,0)),0),0)-1,0),IF(ISODD(SEQUENCE(1,2,1,1)),MID(x_,1,IFERROR(SEARCH("" "",x_)-1,LEN(x_))),IF(ISERROR(SEARCH("" "",x_)),"""",MID(x_,SEARCH("" "",x_)+2,LEN(x_)))))"
Range(.AddressLocal, .End(xlDown).Offset(, 1)).Value = Range(Replace(.Offset(, 3).AddressLocal, "$", "") & "#").Value
.Offset(, 3).ClearContents
End With
End Sub
This uses the function:
=LET(x_,D2:OFFSET(D2,MATCH(0,IFERROR(SEARCH("",D2:OFFSET(D2,ROWS(D:D)-ROWS(D2)-1,0)),0),0)-1,0),IF(ISODD(SEQUENCE(1,2,1,1)),MID(x_,1,IFERROR(SEARCH(" ",x_)-1,LEN(x_))),IF(ISERROR(SEARCH(" ",x_)),"",MID(x_,SEARCH(" ",x_)+2,LEN(x_)))))
... which is an array function that reproduces the original list with relevant cells split as req.
REVISED
Here for sample file (requires Microsoft Onedrive a/c - read only file avail.)
♦ Office 365 compatibility; '3 lines' ignoring with/end/sub/etc.
ta 💪

Replacing Dot to comma in VBA

I have an issue when I try to replace all "." with ","
It works normal when I use Ctrl + H in the Excel Sheet and do it manually.
I have recorded the Macro from what I do in the sheet, and got this code
Columns("Q:S").Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
But when I run the Macro it only removes the "." , instead of replacing it with "," .
So for instance, if the cell states 4.000 aftter I run the Macro, it returns 4000.
How do I fix this??
I have also tried changing decimal separators in the system, but it does not help me.
Thank you for your help.

This should replace all the periods with commas regardless of data type. (as a string, so you'll no longer be able to easily calculate from them)
You'll still be running into a lot of trouble if you want these numbers to be numbers, with correct separators.
As a side note, When I used find and replace (Ctrl + H) I got the same result where my "4.123" became "4,123.00". This may be related to our system settings.
Sub Test_Replace_Period_with_Comma()
Dim ValueRange As Range
Dim ValueSet
Dim X As Long
Dim Y As Long
Set ValueRange = Intersect(Columns("Q:S"), Sheet8.UsedRange)
ValueSet = ValueRange
If ValueRange.Cells.Count = 1 Then
ReDim ValueSet(1 To 1, 1 To 1)
End If
For X = 1 To UBound(ValueSet, 1)
For Y = 1 To UBound(ValueSet, 2)
'Debug.Print ValueSet(X, Y)
If ValueSet(X, Y) <> "" Then
ValueSet(X, Y) = Replace(CStr(ValueSet(X, Y)), ".", ",", 1, , vbTextCompare)
End If
Next Y
Next X
ValueRange.NumberFormat = "#"
ValueRange = ValueSet
End Sub

export excel columns into multiple text files

I need to split data [1...M] gathered in columns [A...N] into separate text files named as first cell of each column.
Data arranged in excel:
FileName_A |FileName_B |FileName_C |… |FileName_N
Data_A1 |Data_B1 |Data_C1 |… |Data_N1
Data_A2 |Data_B2 |Data_C2 |… |Data_N2
Data_A3 |Data_B3 |Data_C3 |… |Data_N3
… … … … …
DataA_AM DataA_BM DataA_CM DataA_AM DataA_NM
____________________________________________________________________________
shall be written into FileNames
FileName_A.tex should look like:
_____________
Data_A1
Data_A2
Data_A3
…
DataA_AM
____________
I´ve tried, but...
Altough it seems an easy task for an expert, it is quite a huge obsticle for me becouse I am not familiar with coding.
Thank You very much for support in advance.

So, I assumed that M is an Integer Variable that you already defined and N just the Column Name (So column number 14). The code would then be
Dim i As Integer
Dim LastRow As Integer
For i = 1 To 14
Range(Cells("2", i), Cells(M, i)).ExportAsFixedFormat _
Type:=xlTypeXPS, _
Filename:=Sheets(1).Cells("1", i), _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
You might want to replace Filename:=Sheets(1).Cells("1", i), _ with Filename:="C:/Your_Path/ & Sheets(1).Cells("1", i), _

Try Code below.
Sub export_data()
Dim row, column, i, j As Integer
Dim fullPath, myFile As String
fullPath = "C:\Workspace"
row = 21
column = 5
For i = 1 To column
myFile = Cells(1, i).Value + ".txt"
myFile = fullPath + "/" + myFile
Open myFile For Output As #1
For j = 2 To row
Print #1, Cells(j, i).Value
Next j
Close #1
Next i
End Sub
You can change Row number and Column number. Your First row is always Header.
See Image below for Excel
Excel Image

Excel VBA Extract Specific Data from Column of Mixed Data

I have a list of Tyres form the internet, the list is 5,000 lines long in one column.
I need to extract from each line the data in BOLD ideally into the next column
EXAMPLE of TYRES
LS388 (145/70 R13 71T)
LS388 (155/65 R13 73T)
LS388 (155/65 R14 75T)
4-Seasons (155/65 R14 75T)
CT6 (155/70 R12 104N) 72EE
LS388 (155/70 R13 75T)
The problem is that the number can be between 59 and 120 and the letter could be H T V R N X Z and so on. Also the text could be anywhere within the line of data not always towards the end as shown.
There could be 100 variations to look for and
Rather than having one line of code to search for a LIKE 71T for each line of tyres, can I use a source table of these variations and reference them one by one in the code is some sort of loop? or other suggestions if in VBA appreciated
At the moment I have this VBA code for each possible variation, one line for each variant.
ElseIf ActiveCell.Value Like "*79S*" Then
ActiveCell.offset(0,1).Value = "79S"

Insert this formula in a cell it is assuming your string is present in column A, you can change it if it is not the case and check how many it extracts.
=MID(A1,SEARCH(" ",A1,SEARCH("R1?",A1))+1,SEARCH(")",A1)-SEARCH(" ",A1,SEARCH("R1?",A1))-1)
filter out the remaining ones, find some thing common in them and let me know and we can build another formula for those cells.

I recommend to use Regular Expressions for that if you need to do it with VBA. There is a pretty good explanation at
How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops.
As pattern you could use something like .+\(.+ (.+)\).* (see https://regex101.com/r/jK1zKc/1/)
For a manual solution
Use Split text into different columns with the Convert Text to Columns Wizard to split into columns by the spaces.
Then do a simple replace ")" by "" in column D.
Or do the manual solution with VBA (assuming your data in column A):
Option Explicit
Sub SplitAndDelet()
Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
")", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)) _
, TrailingMinusNumbers:=True
Range("A:C,E:E").Delete Shift:=xlToLeft
End Sub

If you want to do this in vba you could set up an array of tyres and loop through them for each cell. for example if you had this on your sheet;
you could do something like this;
Public Sub FindTyres()
' Column to Loop
Dim col As String
col = "B"
' rows to Loop
Dim startRow As String
Dim endRow As String
startRow = "2"
endRow = "7"
' Get list of Tyres
Dim tyresArr()
tyresArr = getTyresArr()
' Set Range to Loop
Dim rng As Range, cell As Range
Set rng = Range(col & startRow & ":" & col & endRow)
' Looping through Array params
Dim tyre As Variant
' Loop through Cells
For Each cell In rng
currentCellVal = cell.Value
' Loop through tyres
For Each tyre In tyresArr
Debug.Print tyre
' if you find it do something
If InStr(1, currentCellVal, CStr(tyre)) <> 0 Then
MsgBox "Value " & CStr(tyre) & " Contained in Cell " & cell.Address
Exit For
End If
Next tyre
Next cell
End Sub
Private Function getTyresArr()
Dim tyresArr(3)
tyresArr(0) = "71T"
tyresArr(1) = "73T"
tyresArr(2) = "75T"
tyresArr(3) = "104N"
getTyresArr = tyresArr
End Function
Please note this assumes you will only ever have one tyre code per line.
you may get some false positives if these strings exist for other reasons.
you would need to enter all the codes into the function that returns the array.

VBA - Txt file with two delimiters for rows and columns

I have a .txt file where columns are delimited with | (pipe) but rows are delimited with the following string: _ ~|~ _
Is there a way to import this by delimiting rows based on the string? If I could just do that, I would be able to do text to columns easily.
This is tricky because the space in each row in Notepad is being exhausted. For example:
Policy|Name|Cost _ ~|~ _ 11924|Joe|$20 _ ~|~ _ 154 (end of notepad space)
35|Bob|$40 _ ~|~ _ 18439|Jane|$30 _ ~|~ _ 18492|Ri
chard|$50
I need this to read:
Policy Name Cost
11924 Joe $20
15435 Bob $40
18439 Jane $30
18492 Richard $50
and so on. Note that values at the far right are split because notepad has exhausted its line length.
Thanks for any ideas!

You can pre-process the text before importing to Excel using a more powerful text editor such as TextPad.
In TextPad, do a Replace (F8 key). First let's get rid of your so called "end of notepad space" which I read as line breaks.
Use regular expression to replace double carriage returns "\n\n" with nothing:
Then, replace pipes "\|" with spaces " ":
Then, replace "_ ~ ~ _ " with a carriage return "\n":
This is the final text that should be ready to import into Excel:
Hope that helps! TextPad is a great tool to have around.

You can do this in a single step using a VBA macro.
Read in the entire file to a VBA String variable
Remove the newline characters
Split on the row delimiter
This results in a 1D array
Convert the array to a 2D array
write the results to the worksheet
Do text to columns using the pipe as the delimiter
Option Explicit
'SET REFERENCE to Microsoft Scripting Runtime
Sub ImportSpecial()
Dim FSO As FileSystemObject
Dim TS As TextStream
Dim sFN As Variant
Dim S As String
Dim V As Variant
Dim R As Range
sFN = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If Not sFN = False Then
Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sFN, ForReading, False, TristateFalse)
'Remove the linefeeds
S = TS.ReadAll
S = Replace(S, vbNewLine, "")
'If data is large, will need to transpose manually
V = Application.WorksheetFunction.Transpose(Split(S, "_ ~|~ _"))
Set R = ActiveSheet.Cells(1, 1).Resize(UBound(V), 1)
With R
.EntireColumn.Clear
.Value = V
.TextToColumns Destination:=R(1), _
DataType:=xlDelimited, _
Tab:=False, semicolon:=False, comma:=False, Space:=False, _
other:=True, otherchar:="|"
.EntireColumn.AutoFit
End With
End If
End Sub

Resources