Allora, tu hai un file Sorgente.xls, salvato in una certa posizione; nella stessa posizione e' presente una directory \Fornitoritot, all'interno della quale sono presenti altre subdirectory "di fornitore" e, all'interno di queste subdirectory, dei file "Codice di prodotto"
Il nome del fornitore e' presente in colonna A, il codice di prodotto in colonna B, a partire da riga 2 di Foglio1 (del file Sorgente.xls).
Riprendendo quanto proposto nella discussione precedente, vedi
viewtopic.php?f=26&t=110135, una macro che probabilmente fa quanto proposto e' questa:
- Codice: Seleziona tutto
Sub spalmer()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110135 e viewtopic.php?f=26&t=110284
Dim I As Long, fPath As String, nFile As String, fExt As String, flOk As Boolean
Dim sWs As Worksheet, myNext As Long, shName As String, J As Long, cRow As Long
Dim cForn As String
'
fPath = ThisWorkbook.Path & "\Fornitoritot\"
fExt = ".xls" '<<< Il "tipo" di file Excel da cercare
shName = "Foglio1" '<<< Il Nome del FOGLIO da popolare
'
Set sWs = ActiveSheet
For I = 2 To Cells(Rows.Count, "B").End(xlUp).Row
cRow = 0
cForn = sWs.Cells(I, "A")
nFile = Cells(I, "B").Value & fExt
If Application.WorksheetFunction.CountIf(Range("B2").Resize(I - 1, 1), Cells(I, "B").Value) < 2 Then
On Error Resume Next
Debug.Print "Apro file: >>> " & fPath & cForn & "\" & nFile
Workbooks.Open fPath & cForn & "\" & nFile
On Error GoTo 0
Debug.Print " File attivo: >>> " & ActiveWorkbook.Name
'Si cercano le righe appartenenti a quel fornitore /codice:
For J = I To sWs.Cells(sWs.Rows.Count, "B").End(xlUp).Row
If sWs.Cells(J, "B") & sWs.Cells(J, "A") = sWs.Cells(I, "B") & sWs.Cells(I, "A") Then
cRow = cRow + 1
If UCase(ActiveWorkbook.Name) = UCase(nFile) Then
flOk = True
Sheets(shName).Select
'ricerca prima riga libera:
For k = 0 To 10000
If Range("C22").Offset(k, 0) = "" Then
Exit For
End If
Next k
If k > 9999 Then 'Non trovato riga libera
MsgBox ("Non trovato spazio libero su file " & cForn & "\" & nFile & vbCrLf _
& "Controlla e continua la macro usando il tasto F5")
sWs.Cells(I, "B").Interior.Color = RGB(0, 0, 255) 'nome file in blu, su Sorgente
Stop ' poi Stop
Else
Range("C22").Offset(k, 0).Resize(1, 22).Value = sWs.Cells(J, "C").Resize(1, 22).Value
sWs.Cells(J, "B").Interior.Color = RGB(0, 255, 0)
End If
Else
flOk = False
sWs.Cells(I, "B").Interior.Color = RGB(255, 0, 0)
End If
End If
Next J
'Completato scan righe
If flOk Then
Beep
flOk = False
Else
MsgBox ("File non trovato: " & nFile & vbCrLf & "Righe orfane: " & cRow & vbCrLf & "Controlla, poi continua la macro usando F5")
' Stop
ThisWorkbook.Activate
End If
End If
ThisWorkbook.Activate
'Next riga:
Next I
MsgBox ("Completato...")
End Sub
Mettila in un modulo standard del vba del file Sorgente.xls, poi attiva il foglio con i codici e avvia la Sub spalmer.
La macro parte dal primo fornitore /codice, apre il corrispondente file; cerca sul file Sorgente tutte le righe che appartengono al file appena aperto e copia il contenuto delle colonne C:W da DSorgente a "destinazione"
I codici su Sorgente vengono colorati in verde, il file "destinazione" rimane aperto
La macro passa al successivo fornitore /codice e ripete il processo.
Un messaggio avvisa se non viene trovato il file fornitore /codice, e i codici su Sorgente vengono colorati in Rosso.
Io non so come sono i tuoi dati complessivi; tieni presente che Excel rifiuta di aprire contemporaneamente due file con lo stesso nome; quindi, ad esempio, non potrai aprire un file 12345.xls appartenente al fornitore1 e successivamente (prima di chiudere questo file) aprire un file 12345.xls appartenente al fornitore2
Prova e fai sapere…
