Yeah you are right ,I am very new to coding, collect all these things from many sites and try to complete my project.
I f Display sheet B2, C2, D2 Cells value and Column2 Dates match in retrieval sheet Column 2,3 , 4 and Column 19. then extract data from Retrieval sheet Column 18 & 14 and paste to Display sheet Column 17 & 18.
Hi Carim,
Would you please help me to run this macro with VBA code which is provided in the report attached to the facility index sheet. I have indicate the location in the attached file where I want to run this code.
Option Explicit
Sub Results()
'Produce Results for Columns E,F,G,H,I
Dim c As Range
Dim rng As Range
Dim last1 As Long, last2 As Long
Dim i As Long, col As Long
last1 = Sheets("RetrievalReport").Cells(Rows.Count, "N").End(xlUp).Row
last2 = Sheets("Display").Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For col = 31 To 32
Set rng = Sheets("Display").Range(Cells(2, col), Cells(last2, col))
For Each c In rng
i = c.Row
c = Evaluate("=INDEX(RetrievalReport!" & Col_Letter(col - 18) & "1:" & Col_Letter(col - 18) & last1 & ",MATCH(D" & i & "&B1" & "&C1" & "&D1" & ",RetrievalReport!N1:N" & last1 & "&RetrievalReport!C1:C" & last1 & "&RetrievalReport!D1:D" & last1 & "&RetrievalReport!E1:E" & last1 & ",0))")
c = IIf(IsError(c), "", c)
Next c
Next col
col = 33
Set rng = Sheets("Display").Range(Cells(2, col), Cells(last2, col))
For Each c In rng
i = c.Row
c = Evaluate("=INDEX(RetrievalReport!" & Col_Letter(col - 15) & "1:" & Col_Letter(col - 15) & last1 & ",MATCH(D" & i & "&B1" & "&C1" & "&D1" & ",RetrievalReport!N1:N" & last1 & "&RetrievalReport!C1:C" & last1 & "&RetrievalReport!D1:D" & last1 & "&RetrievalReport!E1:E" & last1 & ",0))")
c = IIf(IsError(c), "", c)
Next c
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End FunctionPrivate Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Sheets("Display").Rows("6:" & Sheets("Display").Rows.Count).Clear
'''''''''''''''''''''Sheets("Display").Range("A5:Z50").ClearContents
''''''''''''''Range(Range("A20"), Cells(Rows.Count, Columns.Count)).ClearContents
Application.EnableEvents = False
If Target.Cells.Count = 1 Then
If Not Intersect(Target, Range("D5:D130")) Is Nothing Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, -1)).Select
Selection.Copy Destination:=Sheets("Display").Range("B2")
With Selection
.Copy
Sheets("Display").Range("B2").PasteSpecial xlPasteValues
End With
''''' 'Sheets("Sheet2").Columns(2).PasteSpecial xlPasteValues
Sheets("Display").Activate
ElseIf Not Intersect(Target, Range("E5:E130")) Is Nothing Then
Range(ActiveCell, ActiveCell.Offset(0, -2)).Select
Selection.Copy Destination:=Sheets("Display").Range("B2")
Sheets("Display").Activate
End If
End If
Application.EnableEvents = True
Worksheets("Lab Report").Range("A5").AutoFilter Field:=3, Criteria1:=Worksheets("Display").Range("B2")
Worksheets("Lab Report").Range("A5").AutoFilter Field:=4, Criteria1:=Worksheets("Display").Range("C2")
Worksheets("Lab Report").Range("A5").AutoFilter Field:=5, Criteria1:=Worksheets("Display").Range("D2")
'Worksheets("Lab Report").Range("A5").AutoFilter Field:=7, Criteria1:=Worksheets("Display").Range("E2") & "" & variable & "*" '''''(search starting word of Cell Value)
'''''Worksheets("Lab Report").Range("A5").AutoFilter Field:=8, Criteria1:=Worksheets("Display").Range("E2")
'''''Worksheets("Lab Report").Range("A5").AutoFilter Field:=7, Criteria1:=Worksheets("Display").Range("D2").Value = Split(Range("D2").Value, "*")(0)
If Worksheets("Lab Report").Range("A5:A100").SpecialCells(xlCellTypeVisible).Count > 1 Then
Worksheets("Lab Report").Range("I6:I500").Copy Destination:=Worksheets("Display").Range("D6")
Worksheets("Lab Report").Range("O6:AN500").Copy Destination:=Worksheets("Display").Range("E6:AD6")
End If
Wan to run Code Here
'Worksheets("Lab Report").Range("Q7:z200").Copy Destination:=Worksheets("Display").Range("K9:U9")
' Worksheets("Lab Report").Range("AA7:DA200").Copy Destination:=Worksheets("Display").Range("V9")
'''2''''Worksheets("RetrievalReport").Range("A5").AutoFilter Field:=3, Criteria1:=Worksheets("Display").Range("B2")
'''2''''Worksheets("RetrievalReport").Range("A5").AutoFilter Field:=4, Criteria1:=Worksheets("Display").Range("C2")
'''2''''Worksheets("RetrievalReport").Range("A5").AutoFilter Field:=5, Criteria1:=Worksheets("Display").Range("D2")
' If Worksheets("RetrievalReport").Range("A5:A100").EntireRow.Hidden = True Then
'''2''''If Worksheets("RetrievalReport").Range("A5:A100").SpecialCells(xlCellTypeVisible).Count > 1 Then
'''2''''Worksheets("RetrievalReport").Range("C7:H200").Copy Destination:=Worksheets("Display").Range("K9")
'''2''''End If
'Worksheets("Lab Report").UsedRange.Offset(2, 6).SpecialCells(xlCellTypeVisible).Copy _
' Destination:=Worksheets("Display").Range("B6")
'Worksheets("Display").Range("C:C,J:J,L:L,P:Q,S:S,X:X,AB:AJ").EntireColumn.Hidden = True
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
'Worksheets("Lab Report").AutoFilterMode = False
Worksheets("Lab Report").AutoFilter.ShowAllData
Worksheets("RetrievalReport").AutoFilter.ShowAllData
End SubHello Carim ,
I have attached file for your reference.
Hi Carim,
Your code is working fine. I have modified it to suit my requirement. However, I want to run this code by clicking on the cell instead of the button. I'm trying to link this code to another VBA that runs after clicking on the cell.
Option Explicit
Sub Results()
'Produce Results for Columns E,F,G,H,I
Dim c As Range
Dim rng As Range
Dim last1 As Long, last2 As Long
Dim i As Long, col As Long
last1 = Sheets("RetrievalReport").Cells(Rows.Count, "N").End(xlUp).Row
last2 = Sheets("Display").Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For col = 31 To 32
Set rng = Sheets("Display").Range(Cells(2, col), Cells(last2, col))
For Each c In rng
i = c.Row
c = Evaluate("=INDEX(RetrievalReport!" & Col_Letter(col - 18) & "1:" & Col_Letter(col - 18) & last1 & ",MATCH(D" & i & "&B1" & "&C1" & "&D1" & ",RetrievalReport!N1:N" & last1 & "&RetrievalReport!C1:C" & last1 & "&RetrievalReport!D1:D" & last1 & "&RetrievalReport!E1:E" & last1 & ",0))")
c = IIf(IsError(c), "", c)
Next c
Next col
col = 33
Set rng = Sheets("Display").Range(Cells(2, col), Cells(last2, col))
For Each c In rng
i = c.Row
c = Evaluate("=INDEX(RetrievalReport!" & Col_Letter(col - 15) & "1:" & Col_Letter(col - 15) & last1 & ",MATCH(D" & i & "&B1" & "&C1" & "&D1" & ",RetrievalReport!N1:N" & last1 & "&RetrievalReport!C1:C" & last1 & "&RetrievalReport!D1:D" & last1 & "&RetrievalReport!E1:E" & last1 & ",0))")
c = IIf(IsError(c), "", c)
Next c
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function