Related
I want to compare two ID lists with different lengths. The first list is longer and has Values, while the second has no Values.
When the ID's match, it should paste the Value in the first list to the appropriate place beside list 2.
Sub compareList()
Dim v1, v2, v4, v3()
Dim i As Long
Dim j As Long
v1 = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
v2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
v4 = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
ReDim v3(1 To 4)
For i = LBound(v1) To UBound(v1)
If IsError(Application.Match(v1(i, 1), v4, 0)) Then
j = j + 1
Else
v3(j) = v2(i, 1)
End If
Next i
Range("E2").Resize(i) = Application.Transpose(v3)
End Sub
It gives me an out of index error, or pastes the value in the order it reads it (without paying attention to the match).
If you do not like Vlookup and need some VBA code, please test the next code:
Sub compareList()
Dim sh As Worksheet, lastR As Long, lastR2 As Long, i As Long, j As Long, arr, arrFin
Set sh = ActiveSheet
lastR = sh.Range("A" & rows.count).End(xlUp).row
lastR2 = sh.Range("D" & rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).Value
arrFin = sh.Range("D2:E" & lastR2).Value
For i = 1 To UBound(arrFin)
For j = 1 To UBound(arr)
If arrFin(i, 1) = arr(j, 1) Then arrFin(i, 2) = arr(j, 2): Exit For
Next j
Next i
sh.Range("D2:E" & lastR2).Value = arrFin
End Sub
Just continuing on and referring to #FaneDuru stating
If you don't like Vlookup and need some VBA code:
1) Example code using Match()
Sub compareListTM()
'define arrays using help function getRange()
Dim arr: arr = getRange(Sheet1.Range("A:A")).Value
Dim data: data = getRange(Sheet1.Range("B:B")).Value
Dim arrFin: arrFin = getRange(Sheet1.Range("D:D")).Value
Dim ret: ret = Application.Match(arrFin, arr, 0) ' Match() items all at once :-)
Dim i As Long
For i = 1 To UBound(ret)
If Not IsError(ret(i, 1)) Then
ret(i, 1) = data(ret(i, 1), 1)
Else
ret(i, 1) = vbNullString
End If
Next i
Sheet1.Range("E2").Resize(UBound(ret), 1).Value = ret
End Sub
If, however you could give VLookUp a try:
2) Example code using worksheetfunction
Sub compareList2()
Dim results
results = WorksheetFunction.VLookup( _
getRange(Sheet1.Range("D:D")), _
getRange(Sheet1.Range("A:B")), _
2, False)
'write results
Sheet1.Range("E2").Resize(UBound(results), 1).Value = results
End Sub
Help function getRange() used in both examples
A way to avoid repeated lastRow, Range definitions in main code.
I don't pretend this function to be perfect in any way, it just meets the necessary requirements for above procedures kept as short as possible.
Function getRange(ColRange As Range, _
Optional ByVal SearchColumn As Variant = 1, _
Optional ByVal StartRow As Long = 2) As Range
'Author : https://stackoverflow.com/users/6460297/t-m
'Purpose: calculate lastrow of a given search column (default: 1st column of ColRange) and
' return ColRange resized to calculated lastrow (considering optional StartRow argument)
'Par. 1 : assumes that ColRange is passed as ENTIRE COLUMN(S) range object, e.g. Range("X:Y")
'Par. 2 : a) a numeric SearchColumn argument refers to the ColRange's column index
' (even outside ColRange, can be negative or higher than columns count in ColRange!)
' b) a literal SearchColumn argument refers to the worksheet column as indicated (e.g. "B")
'Example: getRange(Sheet1.Range("X:Y")) ... calculates lastrow of 1st column in colRange (i.e. in X)
' getRange(Sheet1.Range("X:Y"), "B") ... calculates lastrow of column B in worksheet
'~~~~~~
'1) get columns in ColRange
Dim StartColumn As Long: StartColumn = ColRange.Columns(1).Column
Dim LastColumn As Long: LastColumn = ColRange.Columns(ColRange.Columns.Count).Column
With ColRange.Parent ' i.e. the worksheet
'2) change numeric search column number to letter(s)
If IsNumeric(SearchColumn) Then
If SearchColumn + StartColumn - 1 < 1 Then ' cols left of StartColumn must be at least "A"
SearchColumn = "A"
Else ' get literal column name, e.g. column "D"
SearchColumn = Split((.Columns(SearchColumn + StartColumn - 1).Address(, 0)), ":")(0)
End If
End If
'3) get last row of SearchColumn
Dim lastRow As Long: lastRow = .Range(SearchColumn & .Rows.Count).End(xlUp).Row
If lastRow < StartRow Then lastRow = StartRow ' avoid findings lower than start row
'4) return data range as function result
Set getRange = .Range(.Cells(StartRow, StartColumn), .Cells(lastRow, LastColumn))
End With
End Function
Im not sure exactly how to explain this in a google search so im not sure if anyone else has asked this.
I have a vba function that takes a range and turns it into a string of comma separated values.
It works like a charm.
Now i want it to only output the first 41 entries, switch down a row and output the next 41 entries in the range.
I cant quite wrap my head around it, it feels like a simple loop but i cant quite get there.
I found the csvrange macro online somewhere :)
Function csvRange(myRange As Range)
Dim csvRangeOutput
Dim entry As Variant
For Each entry In myRange
If Not IsEmpty(entry.Value) Then
csvRangeOutput = csvRangeOutput & entry.Value & ","
End If
Next
csvRange = Left(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
Input range would look like this
Desired output would look like this, one string located in column B each group of 41 values separated on a row, offsetting 1 down each time the function hits the next nr 42.
Something like this:
Option Explicit
Public Sub test()
Debug.Print csvRange(Selection, 41)
End Sub
Public Function csvRange(ByVal myRange As Range, ByVal Columns As Long) As String
Dim csvRangeOutput
Dim iCol As Long
Dim Entry As Variant
For Each Entry In myRange
If Not IsEmpty(Entry.Value) Then
iCol = iCol + 1
csvRangeOutput = csvRangeOutput & Entry.Value
If iCol = Columns Then
csvRangeOutput = csvRangeOutput & vbCrLf
iCol = 0
Else
csvRangeOutput = csvRangeOutput & ","
End If
End If
Next
csvRange = Left$(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function
will turn this data
into comma separated values with 41 columns
1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41
42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82
83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123
124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140
Alternative
Public Sub Convert()
Const ColCount As Long = 41
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 1 To LastRow Step ColCount
ws.Cells(iRow \ ColCount + 1, "B").Value = "'" & Join((WorksheetFunction.Transpose(ws.Range("A" & iRow).Resize(RowSize:=IIf(iRow + ColCount - 1 > LastRow, WorksheetFunction.Max(LastRow Mod ColCount, 2), ColCount)).Value)), ",")
Next iRow
End Sub
Please, test the next code. It will do what (I understood) you need, for as many records you have in column A:A. It should be fast, using arrays and working in memory. The single iteration is for the necessary number of range slices:
Private Sub testStringCSVArray()
Dim sh As Worksheet, arr, nrSlices As Long, LastRow As Long, rngF As Range
Dim rngStart As Range, i As Long, k As Long, h As Long, arrFin
Set sh = ActiveSheet
LastRow = sh.Range("A1").End(xlDown).row
LastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of A:A
arr = sh.Range("A1:A" & LastRow).Value 'put the range in an array
nrSlices = UBound(arr) \ 41 'determine the number of necessary slices
ReDim arrFin(nrSlices + 1)
Set rngStart = sh.Range("B" & UBound(arr) + 2) 'set the cell where the result to be returned
For i = 1 To nrSlices + 1
arrFin(h) = CStr(Join(Application.Transpose(Application.Index(arr, _
Evaluate("row(" & k + 1 & ":" & IIf(i <= nrSlices, 41 + k, UBound(arr)) & ")"), 1)), ","))
k = k + 41: h = h + 1
Next i
'Format the range where the processed data will be returned and drop the processed data array:
With rngStart.Resize(h, 1)
.NumberFormat = "#"
.Value = WorksheetFunction.Transpose(arrFin)
End With
End Sub
In order to avoid deleting of the already processed data, in case of whishing to run the code twice or more times, the processed data will be returned in column B:B, two rows down from the last cell in column A:A. If after testing, the code proves to be reliable and no need to run it one more time, Set rngStart = sh.Range("B" & UBound(arr) + 2) can be modified in Set rngStart = sh.Range("A" & UBound(arr) + 2).
Without preliminary formatting as text the area where the data will be dropped, Excel changes the NumberFormat in "scientific", when the comma delimited string contains (only) numbers of three digits each. It looks to consider the comma as a thousands separator...
I have the following columns:
A B
23 75001
42 94
1 13
3 75002
4 12
I would like to sum values of column A if the two first digits of the number in column B is matching 75 or 12.
In this example, the result would be 23 + 3 + 4 = 30.
I tried to use =SUMIFS but it looks like I can only use a criteria based on a integer ...
Do you have an idea how to do this ?
EDIT : I am trying to make a VBA macro
One option using SUMPRODUCT:
=SUMPRODUCT(A1:A5*((--LEFT(B1:B5,2)=75)+(--LEFT(B1:B5,2)=12)))
Similarly, using FILTER if you have access to it:
=SUM(FILTER(A1:A5,((--LEFT(B1:B5,2)=75)+(--LEFT(B1:B5,2)=12))))
Even shorter:
=SUMPRODUCT(A1:A5*(LEFT(B1:B5,2)={"75","12"}))
or if you don't want to put quotes around the numbers
=SUMPRODUCT(A1:A5*(--LEFT(B1:B5,2)={75,12}))
though keeping the quotes around 75 and 12 is a better approach if you have one or more blank cells in B1:B5.
You could use:
=SUMPRODUCT(IF(ISNUMBER(SEARCH({"|75";"|12"},"|"&B1:B5)),A1:A5,0))
Though, if you'd have ExcelO365, you could use SUM() instead. If you need this to be VBA you could mimic this quite easily. Don't let it be mistaken, the other answer is the go-to method, however, this way you could easily add more criteria if need be.
To mimic this in VBA you could use an array and Select Case if you would need to add more criteria in the future:
Sub Test()
Dim lr As Long, x As Long, sm As Double, arr As Variant
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
arr = .Range("A1:B" & lr).Value
For x = LBound(arr) To UBound(arr)
Select Case Left(arr(x, 2), 2)
Case "75", "12": sm = sm + arr(x, 1)
End Select
Next
Debug.Print sm
End With
End Sub
Try the next function, please:
Function countOccLeft(arr As Variant, Cr1 As String, Cr2 As String) As Long
Dim dict As Object, i As Long: Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If Left(arr(i, 2), 2) = Cr1 Or Left(arr(i, 2), 2) = Cr2 Then
If Not dict.Exists("key_sum") Then
dict.Add "key_sum", arr(i, 1)
Else
dict("key_sum") = dict("key_sum") + arr(i, 1)
End If
End If
Next i
countOccLeft = dict("key_sum")
End Function
It can be called in this way:
Sub testCountOccL()
Dim sh As Worksheet, arr As Variant, strSearch As String, lastRow As Long
Set sh = ActiveSheet
lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
arr = sh.Range("A2:B" & lastRow).Value
Debug.Print countOccLeft(arr, "75", "12")
End Sub
What I am trying to do is looping through all rows and columns to find the quantity of a part inside a machine. This is searched for based on the article number and the Equipment/machine type. As in this screenshot:
My problem is that the way I have it running now is VERY slow. In the screenshot above is only a small portion of the cells. They go down to +-500 equalling roughly 22500 times the formula:
=ifERROR(INDEX(Datasheet!$B$1:$E$100;MATCH(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")
I want to speed it up using VBA by just giving my static values in all cells.
I have a large part done which I will display below.
The search values (datasheet)
I have it almost complete (I can feel it!) but it keeps returning me the type 13 Type mismatch error. I have found MANY MANY threads on stack overflow and the internet but these fixes do not fix it for myself.
My code:
'set all sheets
'----------------------------------------
Dim Isht As Worksheet
Dim Esht As Worksheet
Dim Dsht As Worksheet
Dim Gsht As Worksheet
Set Isht = ThisWorkbook.Worksheets("Instructionsheet")
Set Esht = ThisWorkbook.Worksheets("Exportsheet")
Set Dsht = ThisWorkbook.Worksheets("Datasheet")
Set Gsht = ThisWorkbook.Worksheets("Gathersheet")
'----------------------------------------
Dim EshtLR As Long
Dim EshtLC As Long
Dim DshtLC As Long
Dim DshtLR As Long
Dim OutputRange As Range
Dim SearchRange As Range
Dim MachineMatchCOL As Range
Dim ArticleMatchCOL As Range
Dim MachineType As String
Dim ArticleNumber As String
Dim StartRow As Long
Dim StartCol As Long
StartCol = Dsht.Range("P10").Value
StartRow = Dsht.Range("P11").Value
'Determine Last column in export sheet.
EshtLC = Esht.Cells(14, Columns.count).End(xlToLeft).Column
'Determine Last row in data sheet.
DshtLR = Dsht.Cells(Rows.count, 1).End(xlUp).Row
'Determine Last row in export sheet.
EshtLR = Esht.Cells(Rows.count, 1).End(xlUp).Row
Set OutputRange = Esht.Range(Esht.Cells(StartRow, 3), Esht.Cells(EshtLR, EshtLC - 9))
Set SearchRange = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 5))
Set MachineMatchCOL = Dsht.Range(Dsht.Cells(1, 4), Dsht.Cells(DshtLR, 4))
Set ArticleMatchCOL = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 2))
'=IFERROR(INDEX(Datasheet!$B$1:$E$100;Match(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")
'Datasheet!$B$1:$E$100 = SearchRange
'Datasheet!$D:$D = MachineMatchCOL
'Datasheet!$B:$B = ArticleMatchCOL
'C$1 = MatchineType
'$AY15 = ArticleNumber
j = StartRow
i = StartCol
For Each Row In OutputRange
For Each Column In OutputRange
MachineType = Esht.Range(Esht.Cells(1, i), Esht.Cells(1, i)).Value
ArticleNumber = Esht.Range(Cells(j, EshtLC - 5), Cells(j, EshtLC - 5)).Value
Esht.Cells(j, i).Value = Application.WorksheetFunction _
.IfError(Application.WorksheetFunction _
.Index(SearchRange, Application.WorksheetFunction _
.Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")
i = i + 1
Next Column
j = j + 1
Next Row
It has something to do with the fact that a range cannot equal a value but I have tried for a long time and cannot figure it out.
Also note that the loop probably does not work but that is for a next problem to deal with :-).
I do not expect you to fully create everything but, again, a friendly push is also greatly appreciated.
UPDATE: The line that arises error is:
Esht.Cells(j, i).Value = Application.WorksheetFunction _
.IfError(Application.WorksheetFunction _
.Index(SearchRange, Application.WorksheetFunction _
.Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")
Build a dictionary of the Datasheet values using columns B & D joined as the key and column E as the item. This will provide virtually instantaneous 'two-column' lookup for the C15:AU29 table on the Exportsheet worksheet.
Option Explicit
Sub PopulateQIMs()
Dim i As Long, j As Long, ds As Object
Dim arr As Variant, typ As Variant, art As Variant, k As Variant
Set ds = CreateObject("scripting.dictionary")
'populate a dictionary
With Worksheets("datasheet")
'collect values from ws into array
arr = .Range(.Cells(3, "B"), .Cells(.Rows.Count, "E").End(xlUp)).Value2
'cycle through array and build dictionary
For i = LBound(arr, 1) To UBound(arr, 1)
'shorthand overwrite method of creating dictionary entries
'key as join(column B & column D), item as column E
ds.Item(Join(Array(arr(i, 1), arr(i, 3)), Chr(0))) = arr(i, 4)
Next i
End With
With Worksheets("exportsheet")
'collect exportsheet 'Type' into array
'typ = .Range(.Cells(1, "C"), .Cells(1, "AU")).Value2
typ = .Range(.Cells(1, "C"), .Cells(1, "C").End(xlToRight)).Value2
'collect exportsheet 'Article Number' into array
'art = .Range(.Cells(15, "AY"), .Cells(29, "AY")).Value2
art = .Range(.Cells(15, "AY"), .Cells(15, "AY").End(xlDown)).Value2
'create array to hold C15:AU29 values
'ReDim arr(1 To 15, 1 To 45)
ReDim arr(LBound(art, 1) To UBound(art, 1), _
LBound(typ, 2) To UBound(typ, 2))
'cycle through Type and Article Numbers and populate array from dictionary
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
'build a key for lookup
k = Join(Array(art(i, 1), typ(1, j)), Chr(0))
'is it found ...?
If ds.exists(k) Then
'put 'Quantity In Machine' into array
arr(i, j) = ds.Item(k)
End If
Next j
Next i
'put array values into Exportsheet
.Cells(15, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Not sure this exactly meets your needs, nor being the most elegant solution - and running out of time to make this more nicer...
It might not work for you straight out of the box, but i hope it gives you an idea on how to better aproach this.
Sub test()
'set all sheets
'----------------------------------------
Dim Isht As Worksheet
Dim Esht As Worksheet
Dim Dsht As Worksheet
Dim Gsht As Worksheet
Set Isht = ThisWorkbook.Worksheets("Instructionsheet")
Set Esht = ThisWorkbook.Worksheets("Exportsheet")
Set Dsht = ThisWorkbook.Worksheets("Datasheet")
Set Gsht = ThisWorkbook.Worksheets("Gathersheet")
'----------------------------------------
Dim EshtLR As Long
Dim EshtLC As Long
Dim DshtLC As Long
Dim DshtLR As Long
Dim OutputRange As Range
Dim SearchRange As Range
Dim MachineMatchCOL As Range
Dim ArticleMatchCOL As Range
Dim MachineType As String
Dim ArticleNumber As String
Dim StartRow As Long
Dim StartCol As Long
StartCol = Dsht.Range("P10").Value
StartRow = Dsht.Range("P11").Value
'Determine Last column in export sheet.
EshtLC = Esht.Cells(14, Columns.Count).End(xlToLeft).Column
'Determine Last row in data sheet.
DshtLR = Dsht.Cells(Rows.Count, 1).End(xlUp).row
'Determine Last row in export sheet.
EshtLR = Esht.Cells(Rows.Count, 1).End(xlUp).row
'Declare and allocate your ranges to arrays
Dim arrOutput As Variant, arrSearch As Variant
arrOutput = Esht.Range(Esht.Cells(1, 3), Esht.Cells(EshtLR, EshtLC)) 'Not sure what last column is here, but i will make a presumption below that "Article number" is last
arrSearch = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 5))
Dim R As Long, C As Long, X As Long
For R = LBound(arrOutput) To UBound(arrOutput)
For C = LBound(arrOutput, 2) To UBound(arrOutput, 2)
For X = LBound(arrSearch) To UBound(arrSearch)
'If the article number has a match in the search
If arrOutput(R, UBound(arrOutput)) = arrSearch(X, 1) Then 'replace UBound(arrOutput) with the "Article number" column number
'Let's check if the machine number is there as well
If arrOutput(1, C) = arrSearch(X, 3) Then
'both found at the same row, return the value from that row
arrOutput(R, C) = arrSearch(X, 4)
End If
End If
Next X
Next C
Next R
End Sub
PS: You still need to write the values back to the sheet from the array, which you can either do directly range = array or through a loop, depending on your needs.
I`ll try to complete the answer later when i get more time (at work!).
I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub