Ciao Big Skerry,
Post by Big SkerryCiao a tutti
"cerco" di spiegarvi il mio problema
Cartella Pippo
Foglio 1
a1 pippo b1 ciccio c1 lillo d1 999
a2 pluto b2 papo c2 lapo d2 845
Foglio 2 dovrebbe diventare cosi
a1 record1 - b1 pippo
a2 record1 - b2 ciccio bello ("bello" va a cercare ciccio sul foglio3
a3 record1 - b3 lillo viola ("viola" va a cercare lillo sul foglio4
a4 record1 - b4 999
a5 record2 - b5 pluto
a6 record2 - b6 papo pio ("pio" va a cercare papo sul foglio3
ecc....ec...
Il foglio1 potrebbe contenere da 2 fino a un migliaio di righe
E possibile tutto questo con un macro vba
Prova qualcosa del genere:
• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet, SH2 As Worksheet, SH3 As Worksheet
Dim rSorgente As Range, rCerca As Range
Dim arrIn As Variant, arrOut() As Variant, arrCerca As Variant
Dim vVal As Variant
Dim i As Long, j As Long, k As Long, iCtr As Long
Dim LRow As Long, LCol As Long, iRow As Long
Dim UB As Long, UB2 As Long
Dim Res As Variant
Const sFoglio As String = "Foglio1" '<<=== Modifica
Const sFoglio2 As String = "Foglio2" '<<=== Modifica
Const sFoglio3 As String = "Foglio3" '<<=== Modifica
Const iPrimaRigaDati As Long = 2 '<<=== Modifica
Set WB = ThisWorkbook
With WB
Set SH = .Sheets(sFoglio)
Set SH2 = .Sheets(sFoglio2)
Set SH3 = .Sheets(sFoglio3)
End With
With SH
LRow = LastRow(SH, .Columns("A:A"))
LCol = LastCol(SH, .Rows(iPrimaRigaDati))
Set rSorgente = .Range("A" & iPrimaRigaDati). _
Resize(LRow - iPrimaRigaDati + 1, LCol)
End With
With SH3
iRow = LastRow(SH3, .Columns("A:A"))
Set rCerca = .Range("A1:B" & iRow)
End With
arrCerca = rCerca.Value
arrIn = rSorgente.Value
UB = UBound(arrIn)
UB2 = UBound(arrIn, 2)
ReDim arrOut(1 To UB * UB2, 1 To 2)
For i = 1 To UB
For j = 1 To UB2
iCtr = iCtr + 1
vVal = arrIn(i, j)
Res = vbNullString
For k = 1 To UBound(arrCerca)
If arrCerca(k, 1) = vVal Then
Res = arrCerca(k, 2)
Exit For
End If
Next k
arrOut(iCtr, 1) = "Record " & i
arrOut(iCtr, 2) = Trim(arrIn(i, j) & Space(1) & Res)
Next j
Next i
If CBool(iCtr) Then
With SH2
.UsedRange.Columns("A:B").ClearContents
.Range("A1").Resize(UBound(arrOut), 2).Value = arrOut
End With
End If
XIT:
End Sub
'--------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range, _
Optional minRow As Long = 1)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastRow = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If LastRow < minRow Then
LastRow = minRow
End If
End Function
'--------->>
Public Function LastCol(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastCol = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'<<=========
• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire la finestra di gestione delle macro
• Seleziona Tester | Esegui
Potresti scaricare il mio file di prova BigSkewrry20170307.xlsm a:
https://www.dropbox.com/s/z1tiowofm0o2mfr/BigSkerry20170307.xlsm?dl=0
===
Regards,
Norman