Private Sub cmdImp10selectcase_Click()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim sh1 As Worksheet: Set sh1 = wb1.Worksheets("db")
Dim Area As Range, RR As Range
Dim Ur1 As Long, Ur2 As Long, Y As Long, X As Long, Col1 As Long, Col2 As Long, Col3 As Long
Dim ID As String, Percorso As String, nomeFile As String
Dim Col As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Ur1 = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row
sh1.Range("U2:X" & Ur1).ClearContents
Percorso = "\CLUSTERFSSharePiano MarketingDb_MasterDb_Aggiorna_db_newDd_miglior_promo_tot.xlsm" 'new
Dim wb2 As Workbook: Set wb2 = Application.Workbooks.Open(Percorso)
Dim sh2 As Worksheet: Set sh2 = wb2.Worksheets("MP")
For X = 2 To Ur1
Col1 = 1
ID = sh1.Cells(X, 1).Value
For Y = 1 To 4
Col = LettCol(Col1)
Ur2 = sh2.Range(Col & sh2.Rows.Count).End(xlUp).Row
Set RR = sh2.Range(sh2.Cells(2, Col1), sh2.Cells(Ur2, Col1)).Find(ID, LookIn:=xlValues) ' non c'è bisogno di fare SET AREA
If RR Is Nothing Then
Col1 = Col1 + 2
Else
Select Case Col
Case "A"
sh1.Cells(X, 21) = sh2.Cells(RR.Row, Col1 + 1)
Col1 = Col1 + 2
Case "C"
sh1.Cells(X, 22) = sh2.Cells(RR.Row, Col1 + 1)
Col1 = Col1 + 2
Case "E"
sh1.Cells(X, 23) = sh2.Cells(RR.Row, Col1 + 1)
Col1 = Col1 + 2
Case "G"
sh1.Cells(X, 24) = sh2.Cells(RR.Row, Col1 + 1)
Col1 = Col1 + 2
End Select
End If
Next Y
Next X
Application.ScreenUpdating = True
Application.EnableEvents = True
'Application.DisplayAlerts = False
wb2.Close
Application.Quit
ThisWorkbook.Close SaveChanges:=True
'Application.DisplayAlerts = True
Application.Quit
'MsgBox "Aggiornamento eseguito con successo"
Set sh1 = Nothing
Set wb1 = Nothing
Set sh2 = Nothing
Set wb2 = Nothing
Set RR = Nothing
End Sub
Public Function LettCol(ByVal n As Long) As String 'By Scossa
LettCol = Replace(Cells(1, n).Address(False, False), "1", "")
End Function
|