VBA Replace loops for another option

[Mayhem9266]

Hello ladies and gentlemen, i need to improve the speed of this macro:

Sub qpa()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim iniTime!
iniTime = Timer
Dim rMet, rAni, Contar As Integer
Dim anii, anif, meti, metf As Long
Dim anih, meth As String
Worksheets("metallica").Select
Range("s:s").Clear
rMet = 2
rAni = 2
Contar = 0
Do While Cells(rMet, 1) <> ""
meti = Cells(rMet, 13)
metf = Cells(rMet, 14)
meth = Cells(rMet, 18)
    Do While Sheets("antrax").Cells(rAni, 1) <> "" And Contar = 0
    anii = Sheets("antrax").Cells(rAni, 4)
    anif = Sheets("antrax").Cells(rAni, 5)
    anih = Sheets("antrax").Cells(rAni, 7)
        If meti >= anii And metf <= anif And meth = anih Then
            Sheets("metallica").Cells(rMet, 19) = "x"
            Sheets("antrax").Cells(rAni, 8) = "x"
            Contar = 1
        Else
            rAni = rAni + 1
       End If
    Loop
Contar = 0
rAni = 2
rMet = rMet + 1
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
MsgBox "Lo hizo en " & Format(Timer - iniTime, "0.00 seg.")
End Sub

I try to change the loops for If and Mat but I could not do it,

help pls

 

[JLGWhiz]

must have an 'As' with data type, otherwise it is considered by VBA as variant. It does not allow group declarations. I had no way to test this since I have no idea how your worksheets are set up, so be sure you test it before applying to your original file.

Sub qpa()
Application.Calculation = xlCalculationManual
Dim iniTime As Double
Dim Contar As Long, anii As Long, anif As Long, meti As Long, metf As Long
Dim anih As String, meth As String, c As Range, r As Range
iniTime = Timer
With Sheets("metallica")
    Rows(S).Clear   
    For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
        meti = c.Offset(, 12).Value
        metf = c.Offset(, 13).Value
        meth = c.Offset(, 17).Value
        With Sheets("antrax")
            For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))                
                    anii = r.Offset(, 3).Value
                    anif = r.Offset(, 4).Value
                    anih = r.Offset(, 6).Value
                End If
                If meti >= anii And metf <= anif And meth = anih Then
                    Sheets("metallica").Cells(rMet, 19) = "x"
                    Sheets("antrax").Cells(rAni, 8) = "x"
                    Exit For
                Else
                    Exit For
                End If
            Next            
        End With
    Next
End With
Application.Calculation = xlCalculationAutomatic
MsgBox "Lo hizo en " & Format(Timer - iniTime, "0.00 seg.")
End Sub

 

[Mayhem9266]

Hello dear, your code did not work

I have a table on the anthrax page with dates and times, I must look for matches that meet the condition of having the same date and be between the start time and the end time.

Example:

Sheets(antrax)

date                          Star time	Final hour
16/11/16	Machine 1	6:00		14:00
16/11/16	Machine 2	7:00		15:00


Sheets(metallica)


Date				Start time	Final hour           Matches
16/11/16	Machine 1	6:15		6:40  		(yes)
16/11/16	Machine 1	5:59		14:00 		(no) 
16/11/16	Machine 2	6:00		14:01 		(no)
16/11/16	Machine 2	7:01		14:00 		(yes)

 

[JLGWhiz]

this should work

Sub qpa2()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range, rng As Range, adr As String
Dim iniTime As Double
iniTime = Timer
Application.Calculation = xlCalculationManual
Set sh1 = Sheets("antrax")
Set sh2 = Sheets("metallica")
Set rng = sh2.Range("B2", sh2.Cells(Rows.Count, 2).End(xlUp))
    For Each c In sh1.Range("B2", sh1.Cells(Rows.Count, 2).End(xlUp))
        Set fn = rng.Find(c.Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                adr = fn.Address
                Do
                    If fn.Offset(, -1).Value = c.Offset(, -1).Value Then
                        If fn.Offset(, 1).Value >= c.Offset(, 1).Value _
                        And fn.Offset(, 2).Value <= c.Offset(, 2).Value Then
                            fn.Offset(, 3) = "yes"
                        Else
                            fn.Offset(, 3) = "no"
                        End If
                    End If
                    Set fn = rng.FindNext(fn)
                Loop While adr <> fn.Address
            End If
    Next
Application.Calculation = xlCalculationAutomatic
MsgBox "Lo hizo en " & Format(Timer - iniTime, "0.00 seg.")
End Sub

 

[Mayhem9266]

Hello dear, thank you so much for your time,

i have this code:

Option Explicit
Sub Comparar_dos_tablas()

rock_and_roll Sheets("metallica"), "r", Sheets("antrax"), "g", 18
rock_and_roll Sheets("antrax"), "g", Sheets("metallica"), "r", 7

Application.ScreenUpdating = True

End Sub

Private Sub rock_and_roll(ws1 As Worksheet, Col1$, ws2 As Worksheet, Col2$, cRes%)
Dim Mat, Dic, i&, Q&

    Mat = ws2.[a1].CurrentRegion.Columns(Col2).Value
    Q = UBound(Mat)
    Set Dic = CreateObject("Scripting.Dictionary")
        For i = 1 To Q
              Dic.Item(CStr(Mat(i, 1))) = ""
        Next

    Mat = ws1.[a1].CurrentRegion.Columns(Col1).Value
    Q = UBound(Mat)
        For i = 1 To Q
              Mat(i, 1) = IIf(Dic.Exists(CStr(Mat(i, 1))), "X", "")
        Next

    Mat(1, 1) = "xXx"
    ws1.[a1].CurrentRegion.Columns(1).Offset(, cRes) = Mat
    Mat = Empty: Dic = Empty

End Sub

This one finds the matches as I want but i don't know how to add the range conditiion,

I tried your code but it's still slow, the DB has in sheets 1 50000 cells and the other 30000 cells