PDA

View Full Version : [SOLVED] Loops and lookups



MCouture
07-07-2017, 06:41 AM
Hi,
I had this code working last week and then moved a column and something went crazy. I decided to start from scratch today and still can't figure out what I am doing wrong. This is my first VBA so I know it is clunky. I am trying to look up lot values (Material Issued - JobNum) based on the value in cell A1 then list them below the cell. I then need to check those results against a list (Material Issued - JobNum) and get the results (Material Issued - LotNum) added onto the bottom of the first results list, all the way down the results list.


Sub GetMaterial()
j = 1
For i = 2 To Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
If Sheet1.Cells(i, 7).Value = Sheet3.Cells(1, 1) Then
j = j + 1
Sheet3.Cells(j, 1) = Sheet1.Cells(i, 1)
End If
Next i
End Sub

Sub NextLevel()
j = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
For y = 2 To 300
For i = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
If Sheet3.Cells(y, 1).Value = Sheet1.Cells(i, 7) Then
j = j + 1
Sheet3.Cells(j, 1) = Sheet1.Cells(i, 1)
End If
Next i
Next y
End Sub

mdmackillop
07-07-2017, 08:09 AM
First advice; avoid code that will loop 7,591,200 times; it takes too long to run.
If you step through this code and add your own comments, it will intoduce you to a good few concepts to understand.

Option Explicit

Dim wsMat As Worksheet, wsML As Worksheet


Sub GetMaterial()
Dim c As Range, FA As String
Dim JobNo As String
Dim arr1, arr2, a
Dim tgt As Range


Set wsMat = Sheet1
Set wsML = Sheet3

wsML.Range("A1").CurrentRegion.Offset(1).ClearContents

'Get first values
JobNo = wsML.Cells(1, 1).Value
Set tgt = wsML.Cells(Rows.Count, 1).End(xlUp).Offset(1)
arr1 = Data(JobNo)
tgt.Resize(UBound(arr1)) = Application.Transpose(arr1)
'get secondary values
For Each a In arr1
Set tgt = wsML.Cells(Rows.Count, 1).End(xlUp).Offset(1)
arr2 = Data(a)
tgt.Resize(UBound(arr2)) = Application.Transpose(arr2)
Next a
End Sub


Function Data(ToFind As Variant)
Dim arr, c As Range, FA As String
Dim i As Long
ReDim arr(1 To 500)
With wsMat.Columns(7)
Set c = .Find(ToFind, lookat:=xlWhole)
If Not c Is Nothing Then
FA = c.Address
i = 0
Do
i = i + 1
arr(i) = c.Offset(, -6).Value
Set c = .FindNext(c)
Loop Until c.Address = FA
ReDim Preserve arr(1 To i)
Data = arr
Else
ReDim arr(1)
Data = arr
wsML.Columns(1).Find(ToFind).Offset(, 1) = "Not found in column 7"
End If
End With
End Function