Q
QuickLearner
I have a workbook with 2 worksheets.
At he moment I have a dialog that asks me to input a number. It then
filters a range on that number and loops to find cells that meet a
criteria.
These cells are then copied to a single row (from the second coulmn) in
the second worksheet.
What I want to do is replace the dialog and replace it with a loop that
uses the number value in the first column of the second worksheet to to
extract the cells and copy to each row of the second worksheet after
the corresponding number.
I keep getting tripped up here, any advise?
The sub on the first worksheet is:
Sub extract()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim ans As String
Set sh1 = Worksheets("Database")
Set sh2 = Worksheets("Dataset")
sh1.AutoFilterMode = False
sh2.AutoFilterMode = False
With sh1
Set rng = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)) _
..Resize(, 12)
End With
ans = InputBox("Enter Item Number")
If ans = "" Then Exit Sub
If Application.Count(rng.Columns(1), ans) = 0 Then
MsgBox "Not found"
Exit Sub
End If
rng.AutoFilter Field:=1, Criteria1:=ans
maxDate = 0
maxDateRow = 0
highPriRow = 0
highPri = 11 ' assume a pri of 1 is the highest and 10 is the lowest
Dim col As Integer
With sh1
For col = 2 To 8
' rng1 is a reference to the database starting in row 3 - data only -
' no headers
Set rng1 = rng.Offset(1).Resize(rng.Rows.Count - 1, 11)
' rng2 is a refence to the visible cells in column L - starting in row
3
Set rng2 = rng1.Columns(col).SpecialCells(xlVisible)
For Each cell In rng2
' check each row in highPri column
If .Cells(cell.Row, col) <> "" Then
' if cell in not empty
If .Cells(cell.Row, 11) < highPri Then
highPri = Cells(cell.Row, 11).Value
highPriRow = cell.Row
End If
If .Cells(cell.Row, 10) >= maxDate Then
maxDate = .Cells(cell.Row, 10)
maxDateRow = cell.Row
End If
End If
Next
If .Cells(maxDateRow, 11) = highPri And .Cells(maxDateRow, col) <>
"" Then
Debug.Print "Row..." & highPriRow & " Value.." &
..Cells(maxDateRow, col)
..Cells(maxDateRow, col).Copy Destination:=sh2.Cells(2, col)
Else
Debug.Print "Row..." & highPriRow & " Value.." &
..Cells(highPriRow, col)
..Cells(highPriRow, col).Copy Destination:=sh2.Cells(2, col)
End If
' reset high Priority
highPri = 11
Next col
End With
sh1.AutoFilterMode = False
______________________________________________________________
I am not sure how to place the loop to make this work.
Cheers
Wayne
At he moment I have a dialog that asks me to input a number. It then
filters a range on that number and loops to find cells that meet a
criteria.
These cells are then copied to a single row (from the second coulmn) in
the second worksheet.
What I want to do is replace the dialog and replace it with a loop that
uses the number value in the first column of the second worksheet to to
extract the cells and copy to each row of the second worksheet after
the corresponding number.
I keep getting tripped up here, any advise?
The sub on the first worksheet is:
Sub extract()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim ans As String
Set sh1 = Worksheets("Database")
Set sh2 = Worksheets("Dataset")
sh1.AutoFilterMode = False
sh2.AutoFilterMode = False
With sh1
Set rng = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)) _
..Resize(, 12)
End With
ans = InputBox("Enter Item Number")
If ans = "" Then Exit Sub
If Application.Count(rng.Columns(1), ans) = 0 Then
MsgBox "Not found"
Exit Sub
End If
rng.AutoFilter Field:=1, Criteria1:=ans
maxDate = 0
maxDateRow = 0
highPriRow = 0
highPri = 11 ' assume a pri of 1 is the highest and 10 is the lowest
Dim col As Integer
With sh1
For col = 2 To 8
' rng1 is a reference to the database starting in row 3 - data only -
' no headers
Set rng1 = rng.Offset(1).Resize(rng.Rows.Count - 1, 11)
' rng2 is a refence to the visible cells in column L - starting in row
3
Set rng2 = rng1.Columns(col).SpecialCells(xlVisible)
For Each cell In rng2
' check each row in highPri column
If .Cells(cell.Row, col) <> "" Then
' if cell in not empty
If .Cells(cell.Row, 11) < highPri Then
highPri = Cells(cell.Row, 11).Value
highPriRow = cell.Row
End If
If .Cells(cell.Row, 10) >= maxDate Then
maxDate = .Cells(cell.Row, 10)
maxDateRow = cell.Row
End If
End If
Next
If .Cells(maxDateRow, 11) = highPri And .Cells(maxDateRow, col) <>
"" Then
Debug.Print "Row..." & highPriRow & " Value.." &
..Cells(maxDateRow, col)
..Cells(maxDateRow, col).Copy Destination:=sh2.Cells(2, col)
Else
Debug.Print "Row..." & highPriRow & " Value.." &
..Cells(highPriRow, col)
..Cells(highPriRow, col).Copy Destination:=sh2.Cells(2, col)
End If
' reset high Priority
highPri = 11
Next col
End With
sh1.AutoFilterMode = False
______________________________________________________________
I am not sure how to place the loop to make this work.
Cheers
Wayne