I have been trying to Concatenate two Columns directly from the Table1. But i really do not know how. I have tried and make below code.
But I have been creating first 2 helping Column in in "DI" and "DJ" to make this thing work.
I do not want to use these two helping columns directly wants the concatenate result in "DK2"
All help will be appreciaed.
Dim O As String
Dim P As String
O = "Milestone"
P = "Task"
Sheet1.Range("Table1[" & O & "]").Copy
Sheet2.Range("DI2").PasteSpecial xlPasteValues
Sheet1.Range("Table1[" & P & "]").Copy
Sheet2.Range("DJ2").PasteSpecial xlPasteValues
For i = 2 To Cells(Rows.Count, "DH").End(xlUp).Row
Sheet2.Cells(i, "DK").Value = Sheet2.Cells(i, "DI").Value & "" & Sheet2.Cells(i, "DJ").Value
Next i
Here is the example Picture
Try this.
Range("DK2").Resize(Sheet2.ListObjects("Table1").ListRows.Count) = Application.Evaluate("Table1[Milestone]&Table1[Task]")
EDIT: I've seen #norie's answer and it is simpler and more efficient than mine. I'll keep my answer here for anyone who is curious, but I recommend using his solution.
The trick is to use =INDEX(YOUR_TABLE[YOUR_COLUMN]], YOUR_ROW_STARTING_FROM_1) in order to obtain the cell contents that you needed.
Here you are your code edited:
Original
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
Optimized
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using only Formulas (this performs better that the others)
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using Formulas and then converting back to values
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
' Convert from formulas to values
Range("DK:DK").Copy
Range("DK:DK").PasteSpecial xlPasteValues
This can be done directly in the worksheet by using the Index function
Reference first cell in the table: =INDEX(Table1,1,1)
Concatenate cell 1 and 2 values: =INDEX(Table1,1,1)&INDEX(Table1,1,2)
It gets slightly more complicated if you want to be able to copy formulae across or down as you need to reference the current cell location
Reference first cell in the table using offsets: =INDEX(Table1,ROW()-X,COLUMN()-Y) where X, Y (minus data location offsets) are the numerical row/column of the cell where you have placed the formula.
i.e. if placing the formula in E2 to reference Table1 cell(1,1) => =INDEX(Table1,ROW()-1,COLUMN()-4)
where Column E=> Offset 4, Row 2 => Offset 1
or: =INDEX(Table1,ROW()-ROW($E$2)+1,COLUMN()-COLUMN($E$2)+1)
You can now autofill the formula down or across
Concatenate List Columns
With your amount of data both solutions may seem equally efficient. I've tested it with a million rows of random numbers from 1 to 1000, and the first solution took about 3.5 seconds, while the second took about 5.5 seconds on my machine. The first solution is just a more elaborate version of norie's answer.
In this solution, you can add more columns (headers) and use a delimiter. While adding more columns the difference in the efficiencies will become more apparent, while when adding more characters to the delimiter, the efficiencies will decrease seemingly equally.
The Code
Option Explicit
Sub concatListColumnsEvaluate()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Determine table rows count.
Dim rCount As Long: rCount = Sheet1.ListObjects(TableName).ListRows.Count
' Create Evaluate Expression String.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim evString As String
Dim t As Long
If Len(Delimiter) = 0 Then
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&"
Next t
evString = Left(evString, Len(evString) - 1)
Else
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&""" _
& Delimiter & """&"
Next t
evString = Left(evString, Len(evString) - Len(Delimiter) - 4)
End If
' Write values to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Application.Evaluate(evString)
Debug.Print Timer - dTime
End Sub
Sub concatListColumnsArrays()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Write values from list columns to arrays of Data Array.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim Data As Variant: ReDim Data(0 To tUpper)
Dim t As Long
For t = 0 To tUpper
' Either...
Data(t) = Sheet1.Range(TableName & "[" & Headers(t) & "]").Value
' ... or:
'Data(t) = Sheet1.ListObjects(TableName) _
.ListColumns(Headers(t)).DataBodyRange.Value
Next t
' Concatenate values of arrays of Data Array in Result Array.
Dim rCount As Long: rCount = UBound(Data(0), 1)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long
If Len(Delimiter) = 0 Then
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1)
Next t
Next r
Else
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1) & Delimiter
Next t
Result(r, 1) = Left(Result(r, 1), Len(Result(r, 1)) _
- Len(Delimiter))
Next r
End If
' Write values from Result Array to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Result
Debug.Print Timer - dTime
End Sub
Related
(eg: 1=(x1,y1), 3=(x1,y1,x2,y2,x3,y3)
How do i remove the unnecessary "(,)" as shown below and put the number of position of the x,y coordinates of the reliability fail with reference to the number under the header of reliability fails?
Eg: Reliability fail counts =2 in device WLR8~LW~VBD~MNW should give me the position of that fail counts at the same row as the device at columnX. Anyways please ignore the data under the V and W column in my pictures.
Current output based on my code
What i really want
Current issue
Current issue2
where it should be
Dim output As Variant
Dim outputrow As Integer
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
For ia = 2 To lastrow2
If ws1.Cells(ia, "U").Value = 0 Then
output = output & "(" & ws1.Cells(ia, "Y").Value & "," & ws1.Cells(ia, "Z").Value & "),"
ElseIf output = "(,)," Then 'if there are no x and y values in Y and Z column stop showing "(,),"
output = ""
End If
If ws1.Cells(ia, "U").Value > 0 Then
ws1.Cells(ia, "U").Offset(0, 3).Value = Left(output, Len(output) - 1) 'extract the x and y values obtain in (x,y) format
'if there is "value" under reliability fails(column U), put the x y position at the same row as the "value" at column X
End If
Next
End If
I suggest using an inner loop so that extra brackets don't get added in the first place
Option Explicit
Sub test()
Dim output As Variant
Dim outputrow As Integer
Dim valueCount As Long, ib As Long
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
' Outer loop over all rows
For ia = 2 To lastrow2
valueCount = ws1.Cells(ia, "U").Value
output = ""
' Inner loop to process repeated rows
For ib = 1 To valueCount
output = output & "(" & ws1.Cells(ia + ib - 1, "Y").Value & "," & ws1.Cells(ia + ib - 1, "Z").Value & ")"
If ib < valueCount Then output = output & ","
Next ib
ws1.Cells(ia, "U").Offset(0, 3).Value = output
Next ia
End If
End Sub
EDIT
Here is the amended code in light of OP's later example:
Option Explicit
Sub test()
Dim output As Variant
Dim outputrow As Integer
Dim valueCount As Long, ib As Long, rowPointer As Long
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
rowPointer = 2
' Outer loop over all rows
For ia = 2 To lastrow2
valueCount = ws1.Cells(ia, "U").Value
output = ""
' Inner loop to process repeated rows
For ib = 1 To valueCount
output = output & "(" & ws1.Cells(rowPointer, "Y").Value & "," & ws1.Cells(rowPointer, "Z").Value & ")"
If ib < valueCount Then output = output & ","
rowPointer = rowPointer + 1
Next ib
ws1.Cells(ia, "U").Offset(0, 3).Value = output
Next ia
End If
End Sub
First, strip out the extra blank pairs using this:
output = Replace(Range("X" & lRow), ",(,)", "")
You should then have it down to just the pairs you want.
Then split it based on ), and append a ) if it doesnt end in one. Here is an example you can use to incorporate it in your code:
Sub test()
Dim lRow As Long
Dim vSplit As Variant
Dim sResult As String
Dim output as String
For lRow = 2 To 3
If Len(Range("X" & lRow)) > 0 And Val(0 & Range("U" & lRow)) > 0 Then
output = Replace(Range("X" & lRow), ",(,)", "") ' this strips out the extra empty pairs
vSplit = Split(output, "),") ' this creates a string array, 1 item for each pair
sResult = vSplit(Val(Range("U" & lRow)) - 1) ' this gets the one you want based on column U ( -1 because the Split array is 0 based)
If Right$(sResult, 1) <> ")" Then sResult = sResult & ")" ' this adds a ")" if one is missing
Debug.Print sResult ' debug code
Range("X" & lRow) = sResult ' this adds the result to column X, replacing what was there
End If
Next
End Sub
I have an invoice from a service provider that I need to format so I can use the data in Excel. But, the formatting is not consistent.
There are three (3) columns:
ID
Description
Amount
Many ID#s on the invoice have a one line (row) description.
But just as many have 2-11 lines (rows) of description.
The ID# is only listed once with each set of description lines.
Up to this point, I have used Excel Formulas. But, all my formulas is making things go very slow.
VBA would be way faster.
What I have done is created an index system looking for new ID#s.
Then I have created a cascading concatenate formula based on the given index system.
The amount has been easy to pull out using a LEFT formula, since the amount lists USD.
I then have a second sheet that does a VLOOKUP off of the first sheet to pull the ID's, final concatenated descriptions, and Amounts.
Our last invoice had 17,427 lines of data with only 1,717 ID#s.
Here is an example of what I am working with:
I want it to look like this:
one of the possible solutions below:
'assume that Id in column `A`, Description in column `B`, Amount in `C` and header in row 1
Sub somecode()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim sh As Worksheet: Set sh = wb.ActiveSheet
Dim lastRow&: lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
Dim idColumn As Range: Set idColumn = sh.Range("A1:A" & lastRow)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, keyID, valueDescription$, valueAmount$
For Each cl In idColumn
If cl.Value <> "" And Not dic.exists(cl.Value) Then
dic.Add cl.Value, sh.Cells(cl.Row, "B").Value & "|" & sh.Cells(cl.Row, "C").Value
keyID = cl.Value
valueDescription = sh.Cells(cl.Row, "B").Value
valueAmount = sh.Cells(cl.Row, "C").Value
ElseIf cl.Value = "" Then
valueDescription = valueDescription & " " & sh.Cells(cl.Row, "B").Value
dic(keyID) = valueDescription & "|" & valueAmount
End If
Next cl
Set sh = wb.Sheets.Add: sh.Name = "Result " & Date & " " & Replace(Time(), ":", "-")
Dim dkey, xRow&: xRow = 1
For Each dkey In dic
sh.Cells(xRow, "A").Value = dkey
sh.Cells(xRow, "B").Value = Split(dic(dkey), "|")(0)
sh.Cells(xRow, "C").Value = Split(dic(dkey), "|")(1)
xRow = xRow + 1
Next dkey
sh.Columns("A:C").AutoFit
End Sub
test:
I wrote code for you to do this job. Please install it in a standard code module. That is one that you have to insert. None of the existing is suitable.
Option Explicit
Enum Nws ' Worksheet setup (set values as required)
NwsFirstDataRow = 2
NwsNumColumns = 8 ' total number of columns in the sheet
NwsID = 1 ' Columns: 1 = column A
NwsDesc ' undefined = previous + 1
NwsAmt = 5 ' 5 = column E
End Enum
Sub MergeRows()
' Variatus #STO 24 Jan 2020
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Rng As Range
Dim RowArr As Variant
Dim Desc As String, Amt As Double
Dim Tmp As Variant
Dim R As Long
' define workbook and worksheet as required
Set Wb = ActiveWorkbook ' this need not be ThisWorkbook
Set Ws = Wb.Worksheets("Invoice") ' change as appropriate
Application.ScreenUpdating = False
With Ws
R = .Cells(.Rows.Count, NwsDesc).End(xlUp).Row
For R = R To NwsFirstDataRow Step -1
If (R Mod 25) = 3 Then 'NwsFirstDataRow Then
Application.StatusBar = "Another " & R & " rows to process."
End If
Tmp = Trim(.Cells(R, NwsID).Value)
If Len(Tmp) Then
Set Rng = Range(.Cells(R, 1), .Cells(R, NwsNumColumns))
RowArr = Rng.Value
RowArr(1, NwsAmt) = TextToAmount(RowArr(1, NwsAmt))
If Len(Desc) Then
' if you want a comma instead of a line break
' replace Chr(10) with "," in the next line:-
RowArr(1, NwsDesc) = RowArr(1, NwsDesc) & Chr(10) & Desc
RowArr(1, NwsAmt) = RowArr(1, NwsAmt) + Amt
Desc = ""
Amt = 0
End If
With Rng
.Value = RowArr
.Cells.VerticalAlignment = xlTop
.Cells(NwsAmt).NumberFormat = "$#,##0.00"
End With
.Rows(R).AutoFit
Else
Tmp = Trim(.Cells(R, NwsDesc).Value)
If Len(Desc) Then Desc = Chr(10) & Desc
Desc = Tmp & Desc
Tmp = TextToAmount(.Cells(R, NwsAmt).Value)
If Tmp Then Amt = Amt + Tmp
.Rows(R).EntireRow.Delete
End If
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
Private Function TextToAmount(ByVal Amt As Variant) As Double
Dim Tmp As Variant
Tmp = Trim(Amt)
If Len(Tmp) Then Tmp = Mid(Tmp, InStr(Tmp, "$") + 1)
TextToAmount = Val(Tmp)
End Function
Before you can run it you need to set the enumerations at the top to tell the code where your data and columns are. Toward the same end, please set the variables for workbook (Wb) and worksheet (Ws) in the procedure itself.
Note that the code adds the price, if any, in the rows that are deleted to the amount set against the remaining item.
Finally, you will see that I programmed the different rows to become lines in a single cell. That isn't what you asked for. If you want the items separate by commas look for the remark in the code where you can change this.
Currently I am trying to improve the performance of my VBA program, because it takes forever to perform some table operations.
During the programs runtime I am trying to store data in worksheets, but the write-operations take for ever and I would like to store this data dynamically instead of writing it into a worksheet to reduce the time it needs to run.
I was thinking about using arrays instead of the worksheets to store the data but I am not quite sure whether this will work because I do not know how many rows/columns my table exactly has.
Here my code, any help is appreciated!
Public row As Long
Public rowMax As Long
Public startRow As Integer
Public materialType As String
Public filter As String
Public col As Integer
Public colMax As Integer
Public isUsed As Boolean
Public a As Integer
Sub bestimmeObFelderGenutzt()
Debug.Print ("bestimmeObFelderGenutzt:begin" & " " & Now())
With Sheets("Sheet1")
filter = "I"
startRow = 2
rowMax = Sheets("Sheet1").Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets("Sheet1").Cells(1, .Columns.Count).End(xlToLeft).Column
materialType = Sheets("Sheet1").Range(filter & startRow).Value
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Nutzung"
For col = 1 To colMax
Sheets("Nutzung").Cells(1, col + 2).Value = Sheets("Sheet1").Cells(1, col).Value
Next col
For row = 2 To rowMax
Sheets("Nutzung").Range("A" & row).Value = Sheets("Sheet1").Range("A" & row).Value
Sheets("Nutzung").Range("B" & row).Value = Sheets("Sheet1").Range("I" & row).Value
For col = 1 To colMax
If IsEmpty(Sheets("Sheet1").Cells(row, col)) = False Then
isUsed = True
Sheets("Nutzung").Cells(row, col + 2).Value = 1
Else:
Sheets("Nutzung").Cells(row, col + 2).Value = 0
End If
Next col
Next row
End With
Debug.Print ("bestimmeObFelderGenutzt:end" & " " & Now())
End Sub
Sub findeUngenutzteSpalten(ByVal materialType As String, pos As Integer)
Debug.Print ("findeUngenutzteSpalten:begin" & " " & materialType & " " & Now())
With Sheets(materialType)
rowMax = Sheets(materialType).Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets(materialType).Cells(1, .Columns.Count).End(xlToLeft).Column
Sheets("Auswertung").Cells(1, 1).Value = "Spaltenüberschrift:"
Dim a As Integer
For a = 1 To colMax
Sheets("Auswertung").Cells(a + 1, 1).Value = Sheets("Sheet1").Cells(1, a).Value
Next a
Sheets("Auswertung").Cells(1, pos + 1).Value = materialType
For col = 3 To colMax
For row = 2 To rowMax
If Sheets(materialType).Cells(row, col).Value = 1 Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Ja"
GoTo WeiterCol
Else:
If row = rowMax Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Nein"
Else:
GoTo WeiterRow
End If
End If
WeiterRow:
Next row
WeiterCol:
Next col
End With
Debug.Print ("findeUngenutzteSpalten:end" & " " & materialType & " " & Now())
End Sub
Sub kopiereZeilen(ByVal materialType As String)
Debug.Print ("kopiereZeilen:begin" & " " & materialType & " " & Now())
With Sheets("Nutzung")
rowMax = Sheets("Nutzung").Cells(.Rows.Count, "F").End(xlUp).row
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = materialType
Sheets("Nutzung").Cells(1, 1).EntireRow.Copy Sheets(materialType).Cells(1, 1)
Dim unusedRow As Long
For row = 2 To rowMax
unusedRow = Sheets(materialType).Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
If Sheets("Nutzung").Cells(row, 2).Value = materialType Then
Sheets("Nutzung").Cells(row, 2).EntireRow.Copy Sheets(materialType).Cells(unusedRow, 1)
End If
Next row
End With
Debug.Print ("kopiereZeilen:end" & " " & materialType & " " & Now())
End Sub
Sub allesZusammen()
Debug.Print ("Hauptaufruf:begin" & " " & Now())
Dim types(10) As String
Dim element As Variant
Dim pos As Integer
bestimmeObFelderGenutzt
types(0) = "A"
types(1) = "B"
types(2) = "C"
types(3) = "D"
types(4) = "E"
types(5) = "F"
types(6) = "G"
types(7) = "H"
types(8) = "I"
types(9) = "J"
types(10) = "K"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Auswertung"
For Each element In types
kopiereZeilen (element)
pos = Application.Match(element, types, False)
findeUngenutzteSpalten element, pos
Next element
Debug.Print ("Hauptaufruf:end" & " " & Now())
End Sub
You can declare dynamic arrays. The general syntax is:
Dim Values() As Long
To use the array, you must first re-dimension it to the size you want. For example this declares a two-dimensional array of 3 x 5 values (zero based):
ReDim Values(2, 4)
If you want to size based on variables then use something like:
ReDim Values(myrowsize, mycolumnsize)
You can grow (or shrink) the array dynamically by using this syntax:
ReDim Preserve Values(2, mynewsize)
Note, that you can only re-dimension the last index of the array. So this is not allowed:
ReDim Preserve Values(mynewsize, 4)
But this is probably ok in your case, as you have a fixed number of columns.
It is perfectly ok to declare the dynamic array as a UDT. For example:
Type UDTInfo
valueA As Long
valueB As Long
End Type
Sub test()
Dim Values() As UDTInfo
ReDim Values(2, 4)
ReDim Preserve Values(2, 5)
End Sub
You can access the array in the normal way:
x = Values(1, 2)
You can copy one dynamic array to another directly, as long as the types and number of dimensions match (size doesn't matter):
Dim Values() As Integer
Dim Results() As Integer
Results = Values
And lastly, you can pass dynamic arrays to and from functions in the following way:
Function SomeFunc(ByRef Values() As Long) As Long()
Dim ReturnValues() As Long
ReturnValues = Values
SomeFunc = ReturnValues
End Function
Note, you only pass dynamic arrays ByRef but not ByVal.
I have string each on multiple line which looks like this
S087A1097,99,86,0,14,0,good
S087A1097,100,0,10,14,0,good
S087A1097,0,0,100,0,0,good
And I need to change it to this respectively.
S087A1097,99.86,0.14,0,good
S087A1097,100.0,10.14,0,good
S087A1097,0.0,100.0,0,good
How can I achieve this in Excel
if your text is in cell A1:
=SUBSTITUTE(SUBSTITUTE(A1,",",".",2),",",".",3)
If you want to use a VBA solution, you can try the code below.
It might seem a little long, but it's very fast to execute since there is little "messing" with the worksheet, and most of the logic is done on Arrays.
Code
Option Explicit
Sub ImportCsvContents()
Dim csvLines As Variant, CurrentRow As Variant
Dim LastRow As Long, i As Long
ReDim csvLines(0)
With Worksheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' === logic, each order ends with data data in column "B" ===
For i = 1 To LastRow
csvLines(UBound(csvLines)) = .Range("A" & i).Value
ReDim Preserve csvLines(UBound(csvLines) + 1) ' keep record and raise array index by 1
Next i
End With
' resize array to actual populated size
If csvLines(UBound(csvLines)) = "" Then
ReDim Preserve csvLines((UBound(csvLines) - 1))
End If
' loop through all lines in .csv file
For i = 0 To UBound(csvLines)
CurrentRow = Split(csvLines(i), ",")
CurrentRow(1) = CurrentRow(1) & "." & CurrentRow(2)
CurrentRow(2) = CurrentRow(3) & "." & CurrentRow(4)
CurrentRow(3) = CurrentRow(5)
CurrentRow(4) = CurrentRow(6)
' re-format the current line
csvLines(i) = CurrentRow(0) & "," & CurrentRow(1) & "," & CurrentRow(2) & "," & CurrentRow(3) & "," & CurrentRow(4)
Erase CurrentRow ' clear array
Next i
' now just dump the entre array to the worksheet
Worksheets(1).Range("A1").Resize(UBound(csvLines) + 1).Value = Application.Transpose(csvLines)
End Sub
I'm creating a column of custom urls (for import into Mailchimp) and just ran into something that is too tricky for me.
I am building a url column that takes elements from other cells. Almost all the parts of the url will be the same except one (the "Role") variable. Here is how the final url will look where the parts in bold are the variables being fed in from the spreadsheet:
http://domain.com/varPath/?PartName=varEmployee&ClientID=varClient&Role=varRole
The url column fills down the same number of rows that are in column A. Below is a list of the pertinent columns/cells in the spreadsheet for clarification:
Column A = email of all employees completing form
Cell B2 = first name (always using first entry for "varEmployee" in the url)
Cell C2 = last name (same as above)
Column D = varClient (stays the same)
Column E = varRole (THIS IS THE TRICKY ONE since I need to get the changing value)
cell I2 = varPath
The "varEmployee" variable is always going to be the same (B2 + C2)
The same is true of varClient and varPath since we only need the value from the second row (under headers). However the "varRole" variable is going to change with each row since each email in column A is associated with a different role in column E. I'm not sure how to get that value into the url string since it keeps changing. My code is below if anyone has any ideas. Thanks in advance.
Dim lngLastRow As Long
Dim varURL As String
Dim varSurvey As String
Dim varPart As String
Dim varEmployee As String
Dim varRole As String
Dim varClient As String
varURL = "https://domain.com/" + Range("I2").Text
varSurvey = Range("I2").Value
varPart = "?PartName="
varEmployee = Range("B2") + " " + Range("C2")
varRole = "&Role=" + Range("E2")
varClient = "&ClientID=" + Range("D2").Text
varFinal = (varURL & varSurvey & varPart & varEmployee & "&ClientID=" & varClient)
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("F2:F" & lngLastRow).Value = voxFinal
Ok, I read a few more 'for next' posts after seeing Rob's reply and I changed the approach and wrote a slightly different script. This is what I ended up cobbling together which seems to work:
Sub buildURL()
'
' buildURL Macro
'
'
Dim N As Long, i As Long, j As Long
Dim voxURL As String
Dim varSurvey As String
Dim varPart As String
Dim varEmployee As String
Dim varRole As String
Dim varClient As String
varURL = "https://domain.com/" + Range("I2").Text
varSurvey = Range("I2").Value
varPart = "?PartName="
varEmployee = Range("B2") + " " + Range("C2")
varRole = "&Role="
varClient = "&ClientID=" + Range("D2").Text
varFinal = (varURL & varSurvey & varPart & varEmployee & varClient & varRole)
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 2
For i = 2 To N
If Not IsEmpty(Range("A" & i).Value) Then
Cells(j, "F").Value = voxFinal & Cells(i, "E").Value
j = j + 1
End If
Next i
End Sub