Related
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
I have the follow script to put a list of people with there know skills in an array and then match the first match with a customer with the same skill. Every time it runs the results are the same. I would like to have it be a random order of the array, but keeping the two columns in the array together. How can I shuffle(rearrange) the array that keeps the rows in the array the same? Or would it be better to erase the array, randomly sort the columns and set the array back up?
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
p = 0
o = 0
For i = 2 To 920
If Cells(i, 12).Value <> Cells(i - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(i, 12).Value
arOne(p, 1) = Cells(i, 13).Value
o = 2
Else
arOne(p, o) = Cells(i, 13).Value
o = o + 1
End If
Next
For i = 2 To 612
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(i, 2).Value Then
Cells(i, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
GoTo NextIR
End If
Next j
End If
End If
Next o
NextIR:
Next i
End Sub
Multiple loops and multiple access to range objects makes your code very, very slow (I don't know if performance is important).
I would read all necessary data to arrays and use filter and rnd to get a random person with the relevant skill:
Option Explicit
Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
People = Application.Transpose([L2:L920 & "|" & M2:M8])
Customers = Range("A2:C612").Value2
For I = 1 To UBound(Customers, 1)
FilterArray = Filter(People, Customers(I, 2))
If UBound(FilterArray) > -1 Then
Idx = Round(Rnd() * UBound(FilterArray), 0)
Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
End If
Next I
Range("A2:C612").Value = Customers
End Sub
I was able to get done what I needed by erasing the array and redimming it after sorting the data based on a rand() number in the table. It takes about 15 minutes to run 7000 assignment but it is a lot better than 7+ hours it takes to do manually.
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0
QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row
For I = 2 To QAlr
If Cells(I, 12).Value <> Cells(I - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(I, 12).Value
arOne(p, 1) = Cells(I, 13).Value
o = 2
Else
arOne(p, o) = Cells(I, 13).Value
o = o + 1
End If
Next
AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For I = AQAlr + 1 To AgtLr
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(I, 2).Value Then
Cells(I, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
Erase arOne()
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
GoTo NextIR
End If
Next j
End If
End If
Next o
Next I
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation
End Sub
Not entirely sure I got your set-up right but you can try this:
Option Explicit
Sub Assign()
Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents
Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer
For i = 1 To R2.Rows.Count
Rand = Int(R1.Rows.Count * Rnd + 1)
For j = 1 To R1.Rows.Count
If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
D0.Add Rand, Rand
Exit For
End If
Rand = (Rand Mod R1.Rows.Count) + 1
Next j
Next i
End Sub
The idea is to check the people skill list starting from a random point and making sure a key is not used twice.
EDIT:
According to your comment I assume a "people / skill" can then be assigned more than once as there are 7000+ customers ?
Code below randomly assign with a fairly good distribution 1500 peoples to 7000 customers in +/- 1 second.
Have a try and see if you can adapt it to your project.
Option Explicit
Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents
Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer
For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
Set D1 = CreateObject("scripting.dictionary")
For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
ReDim Preserve T3(1 To j)
Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
T3(j) = T1(Rnd_Val, 1)
D1.Add Rnd_Val, Rnd_Val
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
If T3(j) = "" Then
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) Then
T3(j) = T1(Rnd_Val, 1)
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
End If
a = a + 1
If a > R2.Rows.Count Then GoTo EndLoop
Next j
Set D1 = Nothing
Next i
EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub
I did a vb code which is reading multiple text files from a folder and then parsing specific data from it. In the code I have hard coded a folderpath strPath = "C:\Users\smim\Desktop\Mim\Excel\". Now I would like to be able to choose the folder and files manually instead of hard coding the folder path. Here is my code :
Sub Parse()
Dim ws As Worksheet
Dim MyData As String, strData() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Dim count As Variant, yellow As Variant, red As Variant,
Dim YellowC As Variant,RedC As Variant, filecounter As Variant
Dim strPath As String
Application.ScreenUpdating = False
count = 0
red = 0
yellow = 0
YellowC = 0
RedC = 0
strPath = "C:\Users\smim\Desktop\Mim\Excel\"
'Set Book3 = Sheets("Sheet1")
Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
MsgBox ("Started")
'~~> Start from Row 1
'WriteToRow = 1
Cells(3, 1) = "Error"
Cells(3, 1).Interior.ColorIndex = 3
Cells(3, 2) = "Warnings"
Cells(3, 2).Interior.ColorIndex = 6
Cells(1, 3) = "Error"
Cells(1, 3).Interior.ColorIndex = 3
Cells(2, 3) = "Warnings"
Cells(2, 3).Interior.ColorIndex = 6
strCurrentTxtFile = Dir(strPath & "test_*.txt")
' MsgBox (strCurrentTxtFile)
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
Dim list() As String
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbLf)
LineCount = UBound(strData)
' MsgBox (LineCount)
'Assigning length of the list array
ReDim Preserve list(LineCount + 1)
For x = 0 To (LineCount - 1)
'For x = LBound(strData) To UBound(strData)
'Parsing each line to get the result only ( after = sign)
s = Split(strData(x), "=")
b = UBound(s)
'MsgBox (s(1))
'Assigning Values to the list array
list(x) = s(1)
Next
'MsgBox ("This is list" & list(2))
'Active Cell 2
Range("A2").Activate
'Get row number
dblRowNo = ActiveCell.Row
'Get col number
dblColNo = ActiveCell.Column
'MsgBox (dblColNo)
' ReDim Preserve list(LineCount)
For i = 0 To (LineCount - 1)
Cells(3, 3 + i + 1).Value = i
'Looping and assigning Values to the Cell
'For i = LBound(strData) To UBound(strData)
tempParsing = Split(list(i), ":")
' MsgBox (tempParsing(0))
If tempParsing(0) > 0 And tempParsing(0) < 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 6
yellow = yellow + 1
ElseIf tempParsing(0) >= 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 3
red = red + 1
ElseIf tempParsing(0) = 0 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 0
End If
'Looping and assigning Values to the Cell
' For i = LBound(strData) To UBound(strData)
Cells(dblRowNo + count + 2, dblColNo + 1) = yellow
Cells(dblRowNo + count + 2, dblColNo) = red
Cells(dblRowNo + count + 2, dblColNo + i + 3).Value = list(i)
Next
Cells(3 + count + 1, 3).Value = count
count = count + 1
yellow = 0
red = 0
strCurrentTxtFile = Dir
Loop
For t = 4 To 175
If Cells(t, 1).Value > 0 Then
Cells(t, 1).Interior.ColorIndex = 3
End If
If Cells(t, 2).Value > 0 Then
Cells(t, 2).Interior.ColorIndex = 6
End If
Next
'Cells(9, 1) = "linecount = "
'Cells(9, 2) = LineCount
MsgBox "Done"
For f = 4 To 175
If Cells(f, 4).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(f, 4).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For g = 4 To 175
If Cells(g, 7).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(g, 7).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For u = 0 To (LineCount - 1)
Cells(dblRowNo, dblColNo + u + 3) = YellowC
Cells(1, dblColNo + u + 3) = RedC
Next
YellowC = 0
RedC = 0
Application.ScreenUpdating = True
End Sub
I am kind of new to Excel Macros. I have a sample data for which I am trying to write a macro which should perform multiple operations. In the attached excel sheet you could see multiple track# across a single Network#, I want to a put individual track# across there corresponding network#'s and when doing so the space should be trimmed between the N and the number following.
raw data in excel:
X33652 N 4230047169 2013/11/28()
X34704 N4230644769, N4230645169 2014/06/04/m/RB CLRD
X40110 N4230854369, N 4230846569 2014/06/04/B/No Mega
X40605 N 4320617605,N 4320617705,N 4320617805 14/06/12/MayS/CANCELLED/attached email
Ex: Desired output for row 3 is
X40110 N4230854369 2014/06/04/B/No Mega
X40110 N4230846569 2014/06/04/B/No Mega
I am kind of stuck with no help. Any help would be greatly appreciated.
Thanks in Advance.
Here is one of the solutions:
Prerequisites: Sheet1 contains original data (track# in column A, data to split in column B and comment/date in column C), Sheet2 will contain processed data.
Hope that helps.
The code (click Alt+F11, click Insert/Module, paste the code in the inserted module):
Sub test()
Dim a As String, g As String, k As String, l As String
Dim b As Long, c As Long, d As Integer, e As Integer, f As Long, h As Integer, i As Integer, j As Long
b = 1
j = 1
While IsEmpty(Sheet1.Range("A" & b)) = False 'does not check if exceeding excel row limit
b = b + 1
Wend
For c = 1 To b 'Or "2 to b" if data has headers (if first row contains column names)
a = Sheet1.Range("B" & c) 'If column B contains the data to split
k = Sheet1.Range("A" & c) 'network #
l = Sheet1.Range("C" & c) 'date or comment
d = Len(a)
h = 0
For e = 1 To d
If Mid(a, e, 1) = "," Or e = d Then
If h = 0 Then
If e = d Then
i = e
Else
i = e - 1
End If
g = Mid(a, 1, i)
While IsEmpty(Sheet2.Range("B" & j)) = False 'does not check if exceeding excel row limit
j = j + 1
Wend
Sheet2.Range("A" & j) = k
Sheet2.Range("B" & j) = g
Sheet2.Range("C" & j) = l
Else
If e = d Then
g = Mid(a, i + 2, e - i - 1)
Else
g = Mid(a, i + 2, e - i - 2)
End If
While IsEmpty(Sheet2.Range("B" & j)) = False 'does not check if exceeding excel row limit
j = j + 1
Wend
Sheet2.Range("A" & j) = k
Sheet2.Range("B" & j) = g
Sheet2.Range("C" & j) = l
i = e - 1
End If
h = 1
End If
Next e
Next c
Dim m As Long, o As Integer
m = 1 'Or 2 if top row contains headings
Dim n As String
While IsEmpty(Sheet2.Range("B" & m)) = False
Sheet2.Range("B" & m) = Trim(Sheet2.Range("B" & m)) 'trim
n = Sheet2.Range("B" & m)
For o = 1 To Len(n)
If Mid(n, o, 1) = " " Then n = Left(n, 1) & Right(n, Len(n) - 2) 'remove single space
Next o
Sheet2.Range("B" & m) = n
m = m + 1
Wend
End Sub
Try this code (Update according to the comments):
Sub test()
Dim srow As Integer
srow = MsgBox("Does the first row contain data headers (column names)?", vbYesNo + vbQuestion, "First row selection")
If srow = 6 Then
srow = srow - 4
Else
srow = srow - 6
End If
Dim a As String, g As String, k(16383) As String, l(16383) As String
Dim b As Long, c As Long, d As Integer, e As Integer, f As Long, h As Integer, i As Integer, j As Long
b = srow
j = srow
While IsEmpty(Sheet1.Range("A" & b)) = False And b < 1048576
b = b + 1
Wend
b = b - 1
If srow > b Then MsgBox "No entries to analyze!", vbInformation, "Attention!": Exit Sub
Dim spli As String
INPU:
spli = InputBox("Please, enter the Letter of the column, which contains the data to split", "Define split column")
If Len(spli) > 3 Or Len(spli) < 1 Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
Dim letc As Integer
For letc = 65 To 122
If letc <> 91 And letc <> 92 And letc <> 93 And letc <> 94 And letc <> 95 And letc <> 96 Then
If Left(spli, 1) = Chr(letc) Then Exit For
If letc = 122 And Left(spli, 1) <> Chr(letc) Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
End If
Next letc
If Len(spli) > 1 Then
For letc = 65 To 122
If letc <> 91 And letc <> 92 And letc <> 93 And letc <> 94 And letc <> 95 And letc <> 96 Then
If Mid(spli, 2, 1) = Chr(letc) Then Exit For
If letc = 122 And Mid(spli, 2, 1) <> Chr(letc) Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
End If
Next letc
End If
If Len(spli) = 3 Then
For letc = 65 To 122
If letc <> 91 And letc <> 92 And letc <> 93 And letc <> 94 And letc <> 95 And letc <> 96 Then
If Right(spli, 1) = Chr(letc) Then Exit For
If letc = 122 And Right(spli, 1) <> Chr(letc) Then MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
End If
Next letc
If Left(spli, 1) = "Y" Or Left(spli, 1) = "Z" Or Left(spli, 1) = "y" Or Left(spli, 1) = "z" Then
MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
End If
If Left(spli, 1) = "X" Or Left(spli, 1) = "x" Then
If Asc(Mid(spli, 2, 1)) < 65 Or (Asc(Mid(spli, 2, 1)) > 70 And Asc(Mid(spli, 2, 1)) < 97) Or Asc(Mid(spli, 2, 1)) > 102 Then
MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
End If
If Mid(spli, 2, 1) = "F" Or Mid(spli, 2, 1) = "f" Then
If Asc(Right(spli, 1)) < 65 Or (Asc(Right(spli, 1)) > 68 And Asc(Right(spli, 1)) < 97) Or Asc(Right(spli, 1)) > 100 Then
MsgBox "Please, enter a valid Letter of a column", vbCritical + vbOKOnly, "Error!": GoTo INPU
End If
End If
End If
End If
Dim coll As Long, colr As Long, coun As Long
RECL:
coll = InputBox("How many columns to the left of the split data column would you like to copy?", "Left Columns")
If Sheet1.Range(spli & srow).Column - coll < 1 Then
MsgBox "Wrong number of columns indicated", vbExclamation + vbOKOnly, "Error!"
GoTo RECL
End If
RECR:
colr = InputBox("How many columns to the right of the split data column would you like to copy?", "Right Columns")
If Sheet1.Range(spli & srow).Column + colr > 16384 Then
MsgBox "Wrong number of columns indicated", vbExclamation + vbOKOnly, "Error!"
GoTo RECR
End If
For c = srow To b
a = Sheet1.Range(spli & c)
For coun = 0 To coll - 1
k(coun) = Sheet1.Cells(c, Sheet1.Range(spli & c).Column - 1 - coun)
Next coun
For coun = 0 To colr - 1
l(coun) = Sheet1.Cells(c, Sheet1.Range(spli & c).Column + 1 + coun)
Next coun
d = Len(a)
h = 0
For e = 1 To d
If Mid(a, e, 1) = "," Or Mid(a, e, 1) = "/" Or e = d Then
If h = 0 Then
If e = d Then
i = e
Else
i = e - 1
End If
g = Mid(a, 1, i)
While IsEmpty(Sheet2.Range(spli & j)) = False And j < 1048576
j = j + 1
Wend
For coun = 0 To coll - 1
Sheet2.Cells(j, Sheet1.Range(spli & c).Column - 1 - coun) = k(coun)
Next coun
Sheet2.Range(spli & j) = g
For coun = 0 To colr - 1
Sheet2.Cells(j, Sheet1.Range(spli & c).Column + 1 + coun) = l(coun)
Next coun
Else
If e = d Then
g = Mid(a, i + 2, e - i - 1)
Else
g = Mid(a, i + 2, e - i - 2)
End If
While IsEmpty(Sheet2.Range(spli & j)) = False And j < 1048576
j = j + 1
Wend
For coun = 0 To coll - 1
Sheet2.Cells(j, Sheet1.Range(spli & c).Column - 1 - coun) = k(coun)
Next coun
Sheet2.Range(spli & j) = g
For coun = 0 To colr - 1
Sheet2.Cells(j, Sheet1.Range(spli & c).Column + 1 + coun) = l(coun)
Next coun
i = e - 1
End If
h = 1
End If
Next e
Next c
Dim m As Long, o As Integer
m = srow
Dim n As String
While IsEmpty(Sheet2.Range(spli & m)) = False
Sheet2.Range(spli & m) = Trim(Sheet2.Range(spli & m)) 'trim
n = Sheet2.Range(spli & m)
For o = 1 To Len(n)
If Mid(n, o, 1) = " " Then n = Left(n, 1) & Right(n, Len(n) - 2) 'remove single space
Next o
Sheet2.Range(spli & m) = n
m = m + 1
Wend
End Sub
You need to change your code to
Dim i as Long, Temp1 as Str, Temp2() as Str, TempArr() as Str
For i = 1 to 100 ' For e.g. you need 100 rows
Temp1 = Trim(ActiveSheet.Range("A"&i))
TempArr = Split(Temp1," ")
Temp2 = Split(TempArr(1),",")
If Ubound(Temp2) = 1 Then
' i.e. There are 2 values in the second cell,
ActiveSheet.Range("B"&i) = TempArr(0) & " " Temp2(1) & " " & TempArr(2)
Else
' Do nothing
End if
ActiveSheet.Range("B"&i) = TempArr(0) & " " Temp2(0) & " " & TempArr(2)
Next i
This is extremely inefficient but will give an idea how it can be done.
I want this code to search the column name called((attribute value1,attribute value2..N)
If that column contains fraction values, it should convert it to decimal. I'm using this macros(VBA).
The code is working but it is converting only one column(attribute value1).
It will take more time because I have multiple columns(attribute value2...N) that have fraction values.
Please help me out I am struck here.
Sub deci()
Dim LR As Long
Dim Dash As Long
Dim Whole As Double
Dim lngDataColumn As Long
Dim pi
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
For r = 2 To LR
s = Cells(r, lngDataColumn)
arr = Split(s, ",")
For i = LBound(arr) To UBound(arr)
Whole = 0
P = InStr(arr(i), " IN")
If P > 0 Then
Worksheet = (Left((arr(i)), P - 1))
Else
Worksheet = arr(i)
End If
Dash = InStr(Worksheet, "-")
If Dash > 0 Then
Whole = Frac(Left(Worksheet, Dash - 1))
Worksheet = Mid(Worksheet, Dash + 1)
End If
af = Right(arr(i), Len(arr(i)) - P + 1)
evfrac = Whole + Left(CStr(Evaluate(Worksheet)), 5)
' evfrac = Whole + Format(Evaluate(frac), "0.###")
ss = ss & evfrac & af & ", "
Next i
Cells(r, lngDataColumn) = Left(ss, Len(ss) - 2)
ss = ""
Next r
End Sub
Function Frac(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Err.Raise 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac = N
End Function
The reason it's only doing one column is because that's exactly what your telling it to do with this section of the code:
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
Because your setting lngDataColumn as a fixed figure, your code is only executed on column 4. If you want to do more columns as a loop, you need to increment this value in the same maner you are incrementing r in your for loop.
For example:
lngDataColumn = 10
Sheets("Sheet3").Select
For 4 To lngDataColumn
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
'Rest of code
Next lngDataColumn