I need help for Excel convert between 2 values, for example:
I have value number "27-30" I want to convert to "27,28,29,30"
And value character "S-XL" I want to convert to "S, M, L, XL"
The numbers 28,29 and so on can be looped easily but for sizes like S, M and L, you need a lookup table.
Column A contains your sizes and Column E, the lookup for non-numeric sizes,
The code is here, the result on Column B,
Sub sizes()
Dim i As Long, j As Long, str As String, rownum As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(Left(Cells(i, 1), InStr(Cells(i, 1), "-") - 1)) Then
str = Left(Cells(i, 1), InStr(Cells(i, 1), "-") - 1)
For j = Left(Cells(i, 1), InStr(Cells(i, 1), "-") - 1) + 1 To _
Mid(Cells(i, 1), InStr(Cells(i, 1), "-") + 1, 999)
str = str & " , " & j
Next j
Cells(i, 2) = str
Else
rownum = Application.WorksheetFunction.Match(Left(Cells(i, 1), InStr(Cells(i, 1), "-") - 1), Range("E:E"), 0)
str = Cells(rownum, 5)
rownum = rownum + 1
Do Until (Cells(rownum, 5) = Mid(Cells(i, 1), InStr(Cells(i, 1), "-") + 1, 999))
str = str & " , " & Cells(rownum, 5)
rownum = rownum + 1
Loop
str = str & " , " & Cells(rownum, 5)
Cells(i, 2) = str
End If
Next i
End Sub
Related
I have a hard problem that I can't resolve in VBA.
I explain you with a simple example :
I have this database in excel.
my aim is to sum value of apple and apple_1 for column 1,2,3 but for column 4, I want put 1 IFI have just one value who is 1 and 0 IF the 2 value ( apple and apple_1) are 0.
of course, I can have sometimes apple_2 apple_3 apple_4 ... ( I just take an easy example)
Here an example of what I want with VBA :
Please, try the next code. It uses a dictionary and array and due to that it should be fast enough eve for larger ranges:
Sub testProcessFruits()
Dim sh As Worksheet, lastR As Long, arr, arr_, arrIt, arrFin
Dim j As Long, i As Long, dict As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
arr = sh.Range("A1:E" & lastR).Value2
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
If InStr(arr(i, 1), "_") > 0 Then
arr_ = Split(arr(i, 1), "_")
If Not dict.Exists(arr_(0)) Then
dict.Add arr_(0), Array(arr(i, 2), arr(i, 3), arr(i, 4))
Else
arrIt = dict(arr_(0))
For j = 0 To UBound(arrIt) - 1
arrIt(j) = arrIt(j) + arr(i, j + 2)
Next j
dict(arr_(0)) = arrIt
End If
Else
If Not dict.Exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3), arr(i, 4))
Else
arrIt = dict(arr(i, 1))
For j = 0 To UBound(arrIt) - 1
arrIt(j) = arrIt(j) + arr(i, j + 1)
Next j
dict(arr(i, 1)) = arrIt
End If
End If
Next i
ReDim arrFin(1 To dict.count, 1 To 4)
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i)
arrFin(i + 1, 2) = dict.Items()(i)(0)
arrFin(i + 1, 3) = dict.Items()(i)(1)
arrFin(i + 1, 4) = dict.Items()(i)(2)
Next i
With sh.Range("H1")
.Resize(1, 4).Value2 = sh.Range("A1:D1").Value2
.Offset(1).Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
End With
End Sub
i got a data input in sheet1 and sheet2 which gets compared. If there is line(s) in sheet1 that match line(s) in sheet2, then copy and paste the whole line to first possible row in sheet3. It needs to match in column C, D, E, H and I to be a totally match. If everything but column H match, then copy/paste line(s) to sheet4 and state the difference in column H.
So my data is set to have 2 matches and 2 amount differences. The 2 that match is fine in sheet3, but the 2 that doesn't match is the problem, as only one of the lines is shown in sheet4.
Can anyone help me please :)
Code so far:
Sub MatchRows()
Dim a As Variant, b As Variant, c As Variant, d As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim dic As Object, ky As String
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("Sheet1").Range("A1:I" & Sheets("Sheet1").Range("H" & Rows.Count).End(3).Row).Value
b = Sheets("Sheet2").Range("A1:I" & Sheets("Sheet2").Range("H" & Rows.Count).End(3).Row).Value
ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
ReDim d(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 2 To UBound(b, 1)
ky = b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 9)
dic(ky) = i
Next
For i = 2 To UBound(a, 1)
ky = a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 9)
If dic.exists(ky) Then
j = dic(ky)
If a(i, 8) = b(j, 8) Then
k = k + 1
For n = 1 To UBound(a, 2)
c(k, n) = a(i, n)
Next
c(k, 8) = 0
Else
m = m + 1
For n = 1 To UBound(a, 2)
d(k, n) = a(i, n)
Next
d(k, 8) = a(i, 8) - b(j, 8)
End If
End If
Next
If k > 0 Then Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(a, 2)).Value = c
If m > 0 Then Sheets("Sheet4").Range("A" & Rows.Count).End(3)(2).Resize(m, UBound(a, 2)).Value = d
Sheets(3).UsedRange.Columns.AutoFit
Sheets(4).UsedRange.Columns.AutoFit
End Sub
To color the cells set Interior.Color property.
Dim rng as Range
If k > 0 Then
Set rng = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
With rng.Resize(k, UBound(a, 2))
.Value = c
.Interior.Color = RGB(0, 255, 0) ' green
End With
End If
If m > 0 Then
Set rng = Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1)
With rng.Resize(m, UBound(a, 2))
.Value = d
.Interior.Color = RGB(255, 0, 0) ' red
End With
End If
I'm attempting to combine duplicated rows in a table while summing the numbers in the last column, then creating a new summarized table below.
Only the first duplicated row is being summed. This value then appears in all of the rows below.
Example Table - five Columns
Sub CombineDupesV3()
Dim x As Long
Dim r As Long
Dim arr() As Variant
Dim dic As Object
Const DELIM As String = "|"
Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, 1).End(xlUp).Row
arr = Cells(1, 1).Resize(x, 5).Value
For x = LBound(arr, 1) + 1 To UBound(arr, 1)
If dic.exists(arr(x, 1)) Then
arr(x, 5) = arr(x, 5) + CDbl(Split(dic(arr(x, 1)), DELIM)(3))
Else
dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
End If
dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4) & DELIM & arr(x, 5)
Debug.Print "X = " & x
Next x
r = UBound(arr, 1) + 2
Application.ScreenUpdating = False
Cells(r, 1).Resize(, 5).Value = Cells(1, 1).Resize(, 5).Value
r = r + 1
For x = 0 To dic.Count - 1
Cells(r + x, 1).Value = dic.keys()(x)
Cells(r + x, 2).Resize(, 4).Value = Split(dic.items()(x), DELIM)
Cells(r + x, 5).Value = CDbl(Cells(r, 5).Value)
Debug.Print "R = " & r
Next x
Application.ScreenUpdating = True
Erase arr
Set dic = Nothing
End Sub
The conversion line in the last loop should address the correct row value r + x
For x = 0 To dic.Count - 1
Cells(r + x, 1).Value = dic.keys()(x)
Cells(r + x, 2).Resize(, 4).Value = Split(dic.items()(x), DELIM)
'>> convert string to double <<
Cells(r + x, 5).Value = CDbl(Cells(r + x, 5).Value)
Next x
Further hints:
Try to fully qualify all range references in order to avoid unwanted results as unqualified cell addresses refer to the active sheet by default which needn't be the one you have in mind :-)
You should either redefine the data range definition or the target range as they might conflict if you run code twice.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 2 years ago.
Improve this question
i have a problem and i do not know how to solve it.
i have to find a formula in excel or code in vba to highlights the 4 consecutive numbers from a cell B2.
In this cell are 20 numbers (from 1 to 90).
Tray this code, please:
Sub testSplitExtract()
Dim c As Range, arr As Variant, i As Long, boolFound As Boolean
Set c = Range("B2")
arr = Split(c.Value, ",") 'obtain the values array
arraySort arr 'sort the obtained array
For i = 0 To UBound(arr) - 3
If CLng(arr(i)) = CLng(arr(i + 1)) - 1 And _
CLng(arr(i + 1)) = CLng(arr(i + 2)) - 1 And _
CLng(arr(i + 2)) = CLng(arr(i + 3)) - 1 Then
Debug.Print arr(i), arr(i + 1), arr(i + 2), arr(i + 3)
MsgBox arr(i) & "," & arr(i + 1) & "," & arr(i + 2) & "," & arr(i + 3)
boolFound = True: Exit For
End If
Next
If Not boolFound Then MsgBox "No four consecutive numbers in the analized cell"
End Sub
Private Function arraySort(ByRef arrS As Variant) ' function to sort the array
Dim i As Long, j As Long, str1 As Variant, str2 As Variant
For i = 0 To UBound(arrS)
For j = i To UBound(arrS)
If arrS(j) < arrS(i) Then
str1 = arrS(i)
str2 = arrS(j)
arrS(i) = str2
arrS(j) = str1
End If
Next j
Next i
End Function
You could use something like so as discussed above
Function CONSECUTIVE_NUMBERS(strInput As String) As Boolean
Dim a() As String
Dim l As Long
a = Split(strInput, ",")
For l = 0 To UBound(a) - 3
If (Trim(a(l + 1)) - Trim(a(l)) = 1) And _
(Trim(a(l + 2)) - Trim(a(l + 1)) = 1) And _
(Trim(a(l + 3)) - Trim(a(l + 2)) = 1) Then
CONSECUTIVE_NUMBERS = True
Exit For
End If
Next l
End Function
or changing the IF to be
If (Trim(a(l + 1)) - Trim(a(l)) = 1) And _
(Trim(a(l + 2)) - Trim(a(l + 1)) = 1) And _
(Trim(a(l + 3)) - Trim(a(l + 2)) = 1) Then
CONSECUTIVE_NUMBERS = Trim(a(l)) & "," & _
Trim(a(l + 1)) & "," & _
Trim(a(l + 2)) & "," & _
Trim(a(l + 3))
Exit For
End If
and having the a string return from the function to output the 4
Function ConsecutiveFour(myNumbers)
Dim Num, Result
Num = Split(myNumbers, ",")
For i = 0 To UBound(Num) - 3
If WorksheetFunction.And(Num(i + 1) - Num(i) = 1, Num(i + 2) - Num(i + 1) = 1, Num(i + 3) - Num(i + 2) = 1) = True Then
Result = Result & "," & "[" & Num(i) & "," & Num(i + 1) & "," & Num(i + 2) & "," & Num(i + 3) & "]"
End If
Next
ConsecutiveFour = Right(Result, Len(Result) - 1)
End Function
Let's say I have this table :
I would want to see :
A follow up from this question:
I can't for the life of me understand this code in order to add more columns. The code work for 'Name, Type, Food' but I need to add 'Place' and 'date'.
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Feuil1
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array
arr = .Range("A2:C" & lr).Value
'Loop through array
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
dict(arr(x, 1) & "|" & arr(x, 2)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2)), arr(x, 3)), ", ")
Else
dict(arr(x, 1) & "|" & arr(x, 2)) = arr(x, 3)
End If
Next x
'Loop through dictionary
For x = 0 To dict.Count - 1
.Cells(x + 2, 8).Resize(, 2).Value = Split(dict.keys()(x), "|")
.Cells(x + 2, 10).Value = dict.items()(x)
Next x
End With
End Sub
Some relative "simple" adjustments would make this work:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array
arr = .Range("A2:E" & lr).Value
'Loop through array
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) Then
dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)), arr(x, 3)), ", ")
Else
dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = arr(x, 3)
End If
Next x
'Loop through dictionary
For x = 0 To dict.Count - 1
.Cells(x + 2, 6).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(0), "|")
.Cells(x + 2, 8).Value = dict.items()(x)
.Cells(x + 2, 9).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(1), "|")
Next x
End With
End Sub
Hopefully you'll be able to understand. And all good about the unfortunate wording in your original question. No worries.
Happy coding
Here's a generic function which will return a summarized version of a data table, according the the specified "key" and "value" columns.
(only posted here as your follow-up question is still closed: please do not mark this as an answer here)
Sub Tester()
Dim arr
'summarize the input table
arr = Summarize(ActiveSheet.Range("B2").CurrentRegion, Array(1, 2, 4), Array(3, 5))
'put the output on the sheet
ActiveSheet.Range("h2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
'Given an input table rngData (incl. headers), summarize according to
' the "key" columns in arrKeyCols, concatenating values in arrValueCols
' Note: supply column numbers relative to the input range, not the worksheet
' If your table starts in ColB, then the first column is 1, not 2
Function Summarize(rngData As Range, arrKeyCols, arrValueCols)
Dim arr As Variant, arrOut, v
Dim dict As Object, k, r As Long, r2, c As Long, rOut As Long
Set dict = CreateObject("Scripting.Dictionary")
arr = rngData.Value '<< input data, including headers
'Size the output array and copy the headers
' Might have empty "rows" at the end but that's not worth fixing
' given the possible case where no input rows share the same "key"
ReDim arrOut(1 To UBound(arr, 1), 1 To UBound(arr, 2))
For c = 1 To UBound(arr, 2)
arrOut(1, c) = arr(1, c)
Next c
rOut = 2 'start populating output array on this "row"
'loop over the input data
For r = 2 To UBound(arr, 1)
'build the "key" for this row from the key columns passed in arrKeyCols
k = ""
For c = 0 To UBound(arrKeyCols)
k = k & IIf(c > 0, Chr(0), "") & arr(r, arrKeyCols(c))
Next c
'Find the matching row in the output array: if it doesn't exist then create it
If Not dict.exists(k) Then
dict(k) = rOut '<< associate the key with a row in the output array
'populate the key columns in the output array
For c = 0 To UBound(arrKeyCols)
arrOut(rOut, arrKeyCols(c)) = arr(r, arrKeyCols(c))
Next c
r2 = rOut
rOut = rOut + 1 '<< for the next new key
End If
r2 = dict(k) '<< use this row for populating "values" columns
'build the "value" column(s) from arrValueCols
For c = 0 To UBound(arrValueCols)
v = arrOut(r2, arrValueCols(c)) 'extract the existing value
v = v & IIf(Len(v) > 0, ",", "") & arr(r, arrValueCols(c))
arrOut(r2, arrValueCols(c)) = v 're-add the appended value
Next c
Next r
Summarize = arrOut
End Function