Moderatori: Anthony47, Flash30005
Sub Testm()
UR = Sheets("codici DB").Range("C" & Rows.Count).End(xlUp).Row
StrRic = Sheets("selezione").Range("A23").Text
LStR = Len(StrRic)
For CC = 1 To 3
Mtr = 0
For RR = 1 To UR
Tr = 0
StCo = Mid(StrRic, 1, 4)
StCo2 = Right(StrRic, 4)
STrODB = Sheets("codici DB").Cells(RR, CC)
StrDb = Replace(Replace(Replace(STrODB, "COVER_", ""), "ASSEMBLY_", ""), "LUCE_", "")
If Mid(StrDb, 1, 4) <> StCo Then
GoTo saltaRR
End If
If CC = 2 And Len(StrDb) = Len(Replace(StrDb, StCo2, "")) Then GoTo saltaRR
LStrDB = Len(StrDb)
For CCR = 1 To LStR
For CCD = 1 To LStrDB
If Mid(StrRic, CCR, 1) = Mid(StrDb, CCD, 1) Then
Tr = Tr + 1
End If
Next CCD
Next CCR
If Mtr < Tr Then
Mtr = Tr
RiDb = RR
End If
saltaRR:
Next RR
If CC = 1 Then Sheets("selezione").Range("B28").Value = Sheets("codici DB").Range("A" & RiDb).Value
If CC = 2 Then Sheets("selezione").Range("B29").Value = Sheets("codici DB").Range("B" & RiDb).Value
If CC = 3 Then Sheets("selezione").Range("B30").Value = Sheets("codici DB").Range("C" & RiDb).Value
Next CC
End Sub
Sub Testm() '<<<< nome macro
UR = Sheets("codici DB").Range("C" & Rows.Count).End(xlUp).Row '<<<<<<< eliminare
StrRic = Sheets("selezione").Range("A23").Text '<<<<< esistente e lasciare così
Sub Testm() '<<<< nome macro
StrRic = Sheets("selezione").Range("A23").Text '<<<<<<<< esistente
LStR = Len(StrRic)LStR = Len(StrRic) '<<<<<<<<<< esistente
For CC = 1 To 3 '<<<<<<<<<< esistente
UR = Sheets("codici DB").Cells(Rows.Count, CC).End(xlUp).Row '<<<<< inserire questo codice in questo punto
Mtr = 0 '<<<<< esistente
UR = Sheets("codici DB").Cells(Rows.Count, CC).End(xlUp).Row
Sub TRCodici()
Dim FS As Worksheet
Set FS = Sheets("selezione")
FS.Range("B39:B44").ClearContents
For CC = 1 To 6
If CC = 5 And UCase(Right(FS.Range("D27"), 3)) = "000" Then GoTo SaltaCC
If CC = 6 Then
If UCase(Right(FS.Range("D29"), 2)) = "WA" Then
CC = CC + 1
Else
If UCase(Right(FS.Range("D29"), 2)) = "00" Then GoTo SaltaCC
End If
End If
If CC = 3 Then
If UCase(Right(FS.Range("D3"), 2)) = "XL" Then GoTo SaltaCC
If UCase(Right(FS.Range("D13"), 1)) = "0" Then GoTo SaltaCC
End If
UR = Sheets("codici DB").Cells(Rows.Count, CC).End(xlUp).Row
Select Case CC
Case 1
StCo = FS.Range("D5").Text & FS.Range("D7").Text & FS.Range("D9").Text & FS.Range("D11").Text
Case 2
StCo = FS.Range("D5").Text & "_" & FS.Range("D17").Text & FS.Range("D19").Text & FS.Range("D21").Text & FS.Range("D23").Text
Case 3
StCo = Left(FS.Range("D5").Text, 6) & "--" & Right(FS.Range("D5").Text, 2) & "_" & FS.Range("D11").Text
Case 4
StCo = Left(FS.Range("D5").Text, 6) & "--" & Right(FS.Range("D5").Text, 2) & "----" & FS.Range("D13").Text & FS.Range("D15").Text
Case 5
StCo = FS.Range("D5").Text
Case Else
StCo = Left(FS.Range("D5").Text, 3) & "-----" & FS.Range("D3").Text
End Select
For RR = 1 To UR
Tr = 0
StCo1 = Left(StrRic, 13)
StCo2 = FS.Range("D17").Text & FS.Range("D19").Text & FS.Range("D21").Text & FS.Range("D23").Text
StCo3 = Left(FS.Range("D5").Text, 6) & "--" & Right(FS.Range("D5").Text, 2) & "----" & FS.Range("D13").Text & FS.Range("D15").Text
StCo4 = FS.Range("D5").Text
StCo5 = Left(FS.Range("D5").Text, 6) & "--" & Right(FS.Range("D5").Text, 2) & "_" & FS.Range("D11").Text
StCo6 = Left(FS.Range("D5").Text, 3) & "-----" & FS.Range("D3").Text
STrODB = Sheets("codici DB").Cells(RR, CC)
StrDb = Replace(Replace(Replace(Replace(Replace(Replace(STrODB, "COVER_", ""), "ASSEMBLY_", ""), "LUCE_", ""), "EXPL_", ""), "BOX_", ""), "TIPO WA_", "")
If StrDb Like "*" & StCo & "*" Then
If CC = 1 Then FS.Range("B39").Value = Sheets("codici DB").Range("A" & RR).Value
If CC = 2 Then FS.Range("B40").Value = Sheets("codici DB").Range("B" & RR).Value
If CC = 3 Then FS.Range("B43").Value = Sheets("codici DB").Range("C" & RR).Value
If CC = 4 Then FS.Range("B41").Value = Sheets("codici DB").Range("D" & RR).Value
If CC = 5 Then FS.Range("B42").Value = Sheets("codici DB").Range("E" & RR).Value
If CC > 5 Then FS.Range("B44").Value = Sheets("codici DB").Cells(RR, CC).Value
Else
GoTo saltaRR
End If
saltaRR:
Next RR
SaltaCC:
Next CC
End Sub
Torna a Applicazioni Office Windows
Formula per estrarre Stringa di testo da cella Autore: Omocaig |
Forum: Applicazioni Office Windows Risposte: 1 |
definizione automatica di nomi da un elenco Autore: marcoc |
Forum: Applicazioni Office Windows Risposte: 4 |
Visitano il forum: Nessuno e 12 ospiti