I need a macro to get some data from an Excel spreadsheet prior to importing it into MySql linking table.
There is a column of charity names and a column with a list of id's separated by commas (these represent charity types)
To for example
Column A
CharityName1
CharityName2
CharityName3
CharityName4
Column B
100, 101,104
(empty)
104
100,105
I would like this to write a new csv file as follows
1,100
1,101
1,104
3,104
4,100
4,105
Thanks in advance for any help
This code will quickly create a csv file c:\temp\dump.csv with this format
[Updated to handle your format
I note that you may have lost data as Excel has applied scientific notation to your fields. For now I have added an ugly workaround to pad out the 0's. Should B2 be a 30 digit field?]
Sub GetEm()
Dim x()
Dim lngCnt As Long
Dim lngCnt2 As Long
Dim lngE As Long
Dim objFSO As Object
Dim objTF As Object
Dim vArr
Dim vArrElem
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("c:\temp\dump.csv", 2)
x = Application.Transpose(Range("B1", Cells(Rows.Count, "B").End(xlUp)))
For lngCnt = 1 To UBound(x)
lngE = InStr(x(lngCnt), "E")
If lngE > 0 Then
x(lngCnt) = CStr(Replace(Replace(x(lngCnt), ".", vbNullString), "E+", vbNullString) & Application.Rept("0", Right$(x(lngCnt), 2) - lngE + 1))
End If
If Len(x(lngCnt)) > 0 Then
If Len(x(lngCnt)) Mod 3 = 0 Then
For lngCnt2 = 1 To Len(x(lngCnt)) Step 3
objTF.writeline lngCnt & ",'" & Mid$(x(lngCnt), lngCnt2, 3)
Next
End If
End If
Next
objTF.Close
End Sub
I would iterate through the second column and take the values from each cell into an array, lets call it mainArray. (This iterates rows and cols, be warned: How to iterate through a variable-column-length range in Excel using VBA)
Then I would parse until the delimiting ',' and store them in a an array called cellArray with the first value as the numbered cell they were taken from. Then, replace the original cell value in mainArray with the new cellArray. ( String-Manipulation: Split this String delimited by a - character? )
So cell B1 would become cellArray = { 1, 100, 101, 104 } which would be the first value in mainArray. Do this for each cell in column B for the used range.
Then I would create a new csv ( How to create a separate CSV file from VBA? ) and then input the data into it.
To input the data I would loop through each of my saved arrays and store as CellValue = array[0] + ", " + array[i]
Lastly, I would save my new CSV file.
Related
I have an excel file with the following links:
These links are connected to files with the following data:
I want the yellow part of the notepad file to be read into the .xlsx file yellow parts (the notepad is an opened version of the .tbl file). The dotted parts differ for each Version number. (This code is used as a check that the right discount curve is used). However, the discount_curve.tbl format is the only format the next programme used is able to handle. Therefore, it has the same name just in a different folder.
Is there a way excel/vba can read in every third line whilst the file read in depends on the folder link? I strongly prefer to have the whole process automated since there are many many version numbers. Furthermore, I do not want to change the file formatting, since I want the process to be as clean as possible.
Could someone help me out?
Kind regards.
Please, try the next function, if the necessary data to be extracted exists in a single file, at every three rows.. It will return a 2D array able to be dropped at once in the range you need:
Function extractThirdLine(filePath As String) As Variant
Dim arrTxt, i As Long, arrFin, k As Long
'read the file content in an array:
arrTxt = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(filePath, 1).ReadAll, vbCrLf)
ReDim arrFin(1 To Int(UBound(arrTxt) / 3) + 1, 1 To 1)
For i = 2 To UBound(arrTxt) Step 3 'start from 2, because arrTxt is 1D array
k = k + 1
arrFin(k, 1) = arrTxt(i) 'build the filal array containing the necessary rows
Next i
extractThirdLine = arrFin
End Function
Your picture does not show the rows and columns headers. So, supposing that the range you show us exists in columns "A:C" and you need to place the extracted data in column "D:D", please use the next way:
Sub testExtractThirdLine()
Dim filePath As String, arrVal, el
filePath = "your text file full name" 'please write here the correct file name
arrVal = extractThirdLine(filePath)
Range("D1").Resize(UBound(arrVal), 1).value = arrVal
End Sub
If the range you show is not the one I supposed, you cam easily adapt Range("D1") to the immediately after the columns range and its row to be the first row of the range in discussion.
If something not clear enough, please do not hesitate to ask for clarifications.
Edited:
But if each third line can be found in a file, for each row, and the path to the respective file is obtained by concatenation of the three columns, the next function will do the job:
Function extractLine(filePath As String) As String
extractLine = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(filePath, 1).ReadAll, vbCrLf)(2)
End Function
It can be called as:
Sub extractStrings()
Dim i As Long, arr, arrFin, lastRow As Long
lastRow = Range("A" & rows.count).End(xlUp).Row 'supposing that 'C:\' exists in A:A column
arr = Range("A2:C" & lastRow).value
ReDim arrFin(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
arrFin(i, 1) = extractLine(arr(i, 1) & arr(i, 2) & arr(i, 3))
Next i
'drop the processed array content at once:
Range("D2").Resize(UBound(arrFin), 1).value = arrFin
End Sub
Seems like you're looking for common I/O opearations i.e. reading file line by line.
Pretty good example was shown [here][1]
To reach your goal we need to add some if-conditions to extract every third line of your text files.
Modulo division will be a good helper.
For example we have 'i' as row number
then we just need to make an if condition looks smth like that:
If (i mod 3) = 0 Then ...
It means that we're looking for every 'i' which divided by 3 gives us a remainder of 0
This way our code will look something like this
Sub ReadFileLineByLine()
Dim my_file As Integer
Dim text_line As String
Dim file_name As String
Dim i As Integer
file_name = "C:\text_file.txt"
my_file = FreeFile()
Open file_name For Input As my_file
i = 1
While Not EOF(my_file)
Line Input #my_file, text_line
If (i mod 3) = 0 Then
Cells(i, "A").Value = text_line
End If
i = i + 1
Wend
End Sub
[1]: https://excel.officetuts.net/vba/read-a-text-file/#:~:text=Reading%20a%20file%20line%20by%20line,-Let's%20read%20text&text=Open%20VBA%20Edit%20(Alt%20%2B%20F11,and%20insert%20the%20following%20code.&text=First%2C%20a%20new%20file%20is,places%20it%20inside%20a%20worksheet.
You can create a User function that will read the lines from the given file and return the third one.
Here is such a function (Disclaimer: there is no error management in this code it can probably be improved a lot)
Function Get3rdLine(filename As String)
Dim f As Long
f = FreeFile
Open filename For Input As f
Line Input #f, Get3rdLine ' just ignore this line
Line Input #f, Get3rdLine ' and this one too
Line Input #f, Get3rdLine ' and return this one
Close #f
End Function
You can call it with the path of the file you want to read from:
=Get3rdLine(CONCATENATE(A1,B1,C1)) for example if your path is defined by cells A1, B1 and C1.
1.I want to be able to read a value from a cell from a closed workbook & place it in a variable where in each cell is of different type ( i.e. integer or character etc) .Also is it possible to read an entire row in one shot & place it in an array & use it in the program?
Algorithm :
Read from a closed excel file -> I want to know how to open a file & read cell data;
Need to read entire row from column 1 to column 200 of Frist row & need to assign it to a variable in the below fashion, but ensuring the data type is maintained ( i.e string should remain string & integer to remain as integer)
Variable 1 equals Cell value of (A1) where A1 is a string
Variable 2 equals cell value of (B1) where B1 is integer
Varaibale 3 equals cell value of (c1) where C1 is string
::
::
Variable 200 equlals cell value of (row 1 column 200) where value is string
What is the best way to do this.
I should be able through 100 rows & do the step 2 each time for the corresponding rows & columns.
Can you please advise
Step 1
To open a workbook you need to simply give the address of your workbook and assign it to a new variable and by applying the Open method on the object Workbooks you can open it:
Sub OpenWorkbook()
Dim FileName As String
'Assign the address of your file to the variable FileName
FileName = "\FileAddress\FileName.xlsx"
Workbooks.Open FileName
End Sub
Till now you have opened your desired excel workbook.
Step 2
Then you need to read the desired cells of your workbook.
You should assign each cell separately to a new variable.
So you can write the code to do that for you:
Sub OpenWorkbook()
Dim FileName As String
'Assign the address of your file to the variable FileName
FileName = "\FileAddress\FileName.xlsx"
Workbooks.Open FileName
Dim A1 As String
A1 = Workbooks("Excel File Name").Worksheets("Sheet Name").Range("A1")
Dim B1 As Integer
B1 = Workbooks("Excel File Name").Worksheets("Sheet Name").Range("B1")
Dim C1 As Integer
C1 = Workbooks("Excel File Name").Worksheets("Sheet Name").Range("C1")
'You continue until the column 200. If there is some logic you can assign your similar variables by a for loop to an array.
End Sub
Step 3
For your problem you need to define arrays. Otherwise you cannot solve this issue.
If you need to go through 100 lines you need to define an array with the dimension of 100 for each columns. Arrays A(99) starts from A(0) to A(99) which has the dimension of 100.
For example for iterating in 3 columns for 100 rows you can write:
Sub IterationInRows()
Dim A(99) As String, i As Integer
Dim B(99) As Integer
Dim C(99) As String
'Continue through all your variables
For i = 0 to 99
A(i) = Workbooks("Excel File Name").Worksheets("Sheet Name").Ragne("A" & i+1)
B(i) = Workbooks("Excel File Name").Worksheets("Sheet Name").Ragne("B" & i+1)
C(i) = Workbooks("Excel File Name").Worksheets("Sheet Name").Ragne("C" & i+1)
Next i
End Sub
I think by combining these 3 steps you can solve your issue.
If there is a logic in your columns arrangements you can define multi-dimensional arrays and assign all the values of columns with similar data type to that array.
Let say that the odd columns (1, 3, 5, ..., 199) are all strings. Therefore you have 100 columns with string data type and you want to iterate in 100 rows.
So you need to define an array like A(99,99) to iterate through all of them by using two nested for loops.
So you write a code like this:
Sub Iteration2()
Dim A(99,49) As String, i as integer, j as integer
For i = 0 to 99
For j = 0 to 99
A(i,j) = Workbooks("Excel File Name").Worksheets("Sheet Name").Cells(i+1,2*j+1)
Next j
Next i
End Sub
It is possible to close your workbook by code as well. However, you need to assign your workbook to an object and then you apply the method close to that object. But I think you do not need it.
Your question was a bit broad. But I hope I could help you to solve your issue.
I am looking for a way to extract text between 2 characters and copy them to a column at the end of the spreadsheet.
For example, my text looks like [abcdefg], all in Column A, I am looking to extract the text between the "[" and copy it to a new column at the end of the worksheet (as a new column)
Thanks
I would resort to functions since they're just the easiest. To pull the data between 2 characters, you'd use a mixture of MID and FIND functions.
So, assuming your data was in cell A1, you could put this formula in the cell where you want the parsed value:
=MID(A1,FIND("[",A1)+1,FIND("]",A1)-FIND("[",A1)-1)
If you wanted to automate it, you could put it into a macro then copy / paste-special values to remove the function and keep the values.
This is for text in Cell 1, 1 but you can toss some variables in there as you loop through your rows. It will grab the values within square brackets & trim it, additional text can be in front or behind the brackets.
Dim iPos1 As Integer
Dim iPos2 As Integer
iPos1 = InStr(Sheet1.Cells(1, 1), "[")
iPos2 = InStr(Sheet1.Cells(1, 1), "]")
Sheet1.Cells(1, 2) = Trim(Mid(Sheet1.Cells(1, 1), iPos1 + 1, iPos2 - iPos1 - 1))
If you want to write this into a vba module, looping through all entries in the A column and extracting the text inside the [] into an entry in column B, it might look something like:
Dim ws as Worksheet
Dim i as integer
Dim lastRow as Integer
Dim brack1pos as Integer
Dim brack2pos as Integer
Set ws = ThisWorkbook.Worksheets("My Sheet Name")
for i = 1 to lastRow 'I'll leave to you how to find the last row
brack1pos = InStr(ws.Range("A" & i), "[")
brack2pos = InStr(ws.Range("A" & i), "]")
ws.Range("B" & i) = Trim(Mid(ws.Range("A" & i), brack1pos + 1, brack2pos - brack1pos - 1))
next
So imagine there is the following string in a cell in excel:
A1 = "Company 1 Company 2 Company 1 Company 2 Company 3"
and the desired result for now is removing the duplicates:
A1 = "Company 1 Company 2 Company 3" (I imagine that this one doesn't require a macro)
the ideal one would be to put the distinct values in different cells in a vertical way:
A1 = "Company 1"
A2 = "Company 2"
A3 = "Company 3"
(which would require definitely programming but since I never used vba i'm not experienced enough I think to elaborate such code)
Is it feasible?
EDIT: the delimiter can be changed from a space " " to other, for example, a semicolon ";" to prevent errors and to be easier to solve this one.
Asumption is you have a delimiter between the strings to tell apart you could use the following code
Option Explicit
Sub RemoveDuplicates()
Const SEPARATOR = ","
Dim vDat As Variant
vDat = Split(Range("A1"), SEPARATOR)
' remove trailing blanks if necessary
Dim i As Long
For i = LBound(vDat) To UBound(vDat)
vDat(i) = Trim(vDat(i))
Next i
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim vItem As Variant
For Each vItem In vDat
If Not dic.Exists(vItem) Then
dic.Add vItem, vItem
End If
Next
vDat = dic.Keys
' Write data to column B
Range("B1").Resize(UBound(vDat) + 1) = WorksheetFunction.Transpose(vDat)
'Debug.Print Join(vDat, SEPARATOR)
End Sub
Tested with the following data
A1 = Company 1, Company 2, Company 1, Company 2 , Company 3
or
A1 = IBM, Apple, Microsoft, Apple , IBM
With an unambiguous string, and by that I mean:
delimiter not included in the substrings, OR
each entry surrounded by double quotes
you can use Power Query in Excel 2010, 2013 or Data Get & Transform in Excel 2016, to do all of that.
Split the cell on the delimiter
Define the quote mark as the text qualifier if necessary
Rows - remove duplicates
So with data like:
Company 1;Company 2;Company 1;Company 2;Company 3
or (space delimiter)
"Company 1" "Company 2" "Company 1" "Company 2" "Company 3"
you can easily accomplish what you require without using VBA.
And if, as in your examples, there are extraneous spaces at the beginning or end of the data, Power Query has a Text.Trim function that will be useful.
Alternate solution using UDF (commented for clarity):
Public Function UNIQUELIST(ByVal arg_vOriginalList As String, ByVal arg_sDelimiter As String, ByVal arg_lReturnIndex As Long) As Variant
Dim oDict As Object
Dim vElement As Variant
Dim i As Long
'Use a dictionary to extract unique elements
Set oDict = CreateObject("Scripting.Dictionary")
i = 0 'This is a counter to keep track until we reach the appropriate return index
'Loop through each element
For Each vElement In Split(arg_vOriginalList, arg_sDelimiter)
'Check the trimmed, lowercase element against the keys of the dictionary
If Not oDict.Exists(LCase(Trim(vElement))) Then
'Unique element found
i = i + 1
If i = arg_lReturnIndex Then
'Found appropriate unique element, output and exit function
UNIQUELIST = Trim(vElement)
Exit Function
End If
'Not correct return index, add element to dictionary
'Lowercase the key (so uniques aren't case sensitive) and trim both the key and the value
oDict.Add LCase(Trim(vElement)), Trim(vElement)
End If
Next vElement
'arg_lReturnIndex was less than 1 or greater than the number of unique values, return blank
UNIQUELIST = vbNullString
End Function
Then in a cell where you want the output to start (for example, B1), put this formula and copy down (adjust the "," to be the correct delimiter):
=UNIQUELIST($A$1,",",ROW(A1))
Approach using same delimiters as in OP
I assume the same space delimiters as in your original post: As you want to get your company strings in groups of two, I slightly modified the good solution of #Storax by concatenating the Split result in steps of 2 first and demonstrate a shorter way to write results back to sheet (cf. section [5]).
Example Code
Option Explicit ' declaration head of your code module
Sub SplitCompanies()
' [0] declare variables and set objects
Dim v, vItem
Dim i As Integer, n As Integer
Dim s, str As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tabelle5") ' << change to your sheet name
Dim dict As Object ' late binding of dictionary
Set dict = CreateObject("Scripting.Dictionary")
' [1] get cell value and split it (space delimited as in Original Post)
str = ws.Range("A1") ' cell value, e.g. "Company 1 Company 2 Company 1 Company 2 Company 3"
s = Split(str, " ") ' split cell value (space delimiter)
' [2] count all companies and redimension helper array
n = Int((UBound(s) + 1) / 2) - 1 ' items counter equals 1/2 of split items
ReDim v(0 To n) ' redim zero-based 1-dim helper array
' [3] concatenate partial strings in helper array
For i = 0 To n
v(i) = s(i * 2) & " " & s(i * 2 + 1)
Next i
' [4] build dictionary with unique items
For Each vItem In v
If Not dict.Exists(vItem) Then
dict.Add vItem, vItem
End If
Next
' [5] Write data to column B
ws.Range("B1:B" & dict.Count) = Application.Transpose(dict.Keys)
' [6] clear memory
Set dict = Nothing: Set ws = Nothing
End Sub
Does anyone have an idea how to write VBA in Excel to export multiple rows to just one column. Additionally, I would like to add "enter" at the end of each "row". Ideally, this would be exported in .txt, but it would be already great even if it is converted inside the same document.
Thank you!
Edit: For example: I have rows which contain some text/value A1:A5, B1:B5, ... I would need all of These rows to get "moved" in a single column D for instance. So, A1 would go to D1,A2-D2, A3-D3 ... B1 to D7 and so on. After each end (A5, B5, C5,...) I would need an empty cell (when I convert this to .txt it means enter). I hope it is a bit clearer now.
The code below will do what you describe. Use the constants in the beginning to set how many columns and rows that should be moved to one single column, specified by TargetColNo. An empty cell will be added after each scanned column.
If you prefer to save it to a textfile you can use this code and add a text file to add the result in instead of a column.
Sub Rows2OneColumn()
Const StartColumnNo = 1 ' Start at column A
Const EndColNo = 3 ' End at column C
Const StartRowNo = 1 ' Start at row 1
Const EndRowNo = 5 ' End at row 5
Const TargetColNo = 5 ' Put result in column E
Dim source_row As Integer
Dim source_col As Integer
Dim target_row As Integer
target_row = 1
For source_col = StartColumnNo To EndColNo
For source_row = StartRowNo To EndRowNo
Cells(target_row, TargetColNo).Value = Cells(source_row, source_col).Value
target_row = target_row + 1
Next
target_row = target_row + 1 ' leave one cell empty
Next
End Sub
you need add reference Microsoft ActiveX Data Objects 2.8 Library
Set ff = CreateObject("ADODB.Stream")
ff.Type = 2
ff.Charset = "utf-8"
ff.Open
For Each Cell In Range("A1:D5").Cells
ff.WriteText Cell.Value & vbNewLine
Next
path_to_save = ActiveWorkbook.Path
ff.SaveToFile path_to_save & "\test.txt", 2