Option Compare Text 'nessuna diff tra maius e minus
Option Explicit
  Dim sha As Worksheet, shr As Worksheet
  Dim c As Range, d As Range, E As Range

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode <> 1 Then
    MsgBox ("Usa il pulsante CHIUDI per terminare il lavoro"), vbInformation
    Cancel = True
End If
End Sub

Private Sub CommandButton1_Click()
Dim N1 As String, n2 As String, n3 As String
Dim Ro As Integer
Set shr = Worksheets("ricerca")
Set sha = Worksheets("archivio")
Application.ScreenUpdating = False
On Error Resume Next
N1 = TextBox1.Text
n2 = TextBox2.Text
n3 = ComboBox2.Value
Ro = 2
shr.Activate
shr.Range("A2:V3000").ClearContents
If ComboBox1 = "" Then
MsgBox ("ATTENZIONE CAMPO UFFICIO OBBLIGATORIO"), vbCritical
Exit Sub
End If
'''''''''''''''''''''''''''''''''
If TextBox2 <> "" And TextBox1 <> "" Then
MsgBox ("ATTENZIONE   SCEGLIRE SOLO UN NOME")
Exit Sub
Else
For Each c In sha.Range("E:E")
        If c.Value = "" Then Exit For
        If c.Value = N1 And c.Offset(, 2) = ComboBox1 And c.Offset(, 3) = ComboBox2 Then
        Range(c.Offset(0, -4), c.Offset(0, 17)).Copy
        shr.Cells(Ro, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Ro = Ro + 1
        Else
        If c.Value = N1 And c.Offset(, 2) = ComboBox1 Then
        Range(c.Offset(0, -4), c.Offset(0, 17)).Copy
        shr.Cells(Ro, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Ro = Ro + 1
        End If
        End If
Next c
End If
shr.Activate
shr.Cells(2, 1).Select
If shr.Cells(2, 1) <> "" Then
GoTo 10
Else
For Each d In sha.Range("F:F")
        If d.Value = "" Then Exit For
        If d.Value = n2 And d.Offset(, 1) = ComboBox1 And c.Offset(, 3) = ComboBox2 Then
        Range(d.Offset(0, -5), d.Offset(0, 16)).Copy
        shr.Cells(Ro, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Ro = Ro + 1
        Else
        If d.Value = n2 And d.Offset(, 1) = ComboBox1 Then
        Range(d.Offset(0, -5), d.Offset(0, 16)).Copy
        shr.Cells(Ro, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Ro = Ro + 1
        End If
        End If
Next d
End If

If shr.Cells(2, 1) <> "" Then
GoTo 10
Else
If shr.Cells(2, 1) = "" Then
For Each E In sha.Range("H:H")
        If E.Value = "" Then Exit For
        If E.Value = n3 And E.Offset(, -1) = ComboBox1 And c.Offset(, 3) = ComboBox2 Then
        Range(E.Offset(0, -7), E.Offset(0, 14)).Copy
        shr.Cells(Ro, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Ro = Ro + 1
        Else
        If E.Value = n3 And E.Offset(, -1) = ComboBox1 Then
        Range(E.Offset(0, -7), E.Offset(0, 14)).Copy
        shr.Cells(Ro, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        Ro = Ro + 1
        End If
        End If
Next E
End If
End If
'''''''''''''''''''''''''''''''''''''''''''
10:
If shr.Cells(2, 1) = "" Then
MsgBox "Nessuna corrispondenza", vbInformation
Else
MsgBox "Ricerca effettuata con successo", vbInformation
ComboBox3.RowSource = "ricerca!a2:a1500"
End If
Exit Sub
shr.Cells(1, 1).Select
End Sub

Private Sub ComboBox1_AfterUpdate()
Dim x As Long, R As Long, ind, SH As Worksheet, xx As Long, XXX As Long
Set SH = Worksheets("VIARIO")
ind = ActiveSheet.Name
If ComboBox1 = "" Then Exit Sub
Application.ScreenUpdating = False
SH.Activate
For x = 3 To 8
   If SH.Cells(1, x) = ComboBox1 Then
        R = SH.Cells(Rows.Count, x).End(xlUp).Row
       ComboBox2.RowSource = SH.Range(Cells(2, x), Cells(R, x)).Address
     Exit For
    End If
Next x
For xx = 27 To 31
   If SH.Cells(1, xx) = ComboBox1 Then
        R = SH.Cells(Rows.Count, xx).End(xlUp).Row
       ComboBox4.RowSource = SH.Range(Cells(2, xx), Cells(R, xx)).Address
     Exit For
    End If
Next xx
Sheets(ind).Select
Application.ScreenUpdating = True
End Sub