ciao allora possiamo fissare la colonna C "tipo"...
ho testato la macro modificando delle celle, ma mi si colorano completamente le pagine 3 e 4...
Moderatori: Anthony47, Flash30005
Dim PArr, SArr, KArr, my2Ag, myKey As Long
Dim Primo As String, Secondo As String, Report As String, Lay0 As String
Sub myConfr()
'
Dim FreeCol As String
Dim LastP As Long, LastS As Long, LayLargh As Long
Dim I As Long, I2 As Long
'
'>>>Qualche parametro
Lay0 = "A2" 'L' inizio delle tabelle
LayLargh = 20 'La larghezza delle tabelle
'FreeCol = "Z"
Primo = "Foglio1" 'Il nome del primo Foglio
Secondo = "Foglio2" 'Il nome del secondo Foglio
Report = "Foglio5" 'Il nome del foglio su cui produrre il report <<VEDI TESTO
myKey = 1 'Quale colonna contiene il Codice Agenzia
'
With Sheets(Report).Cells
.Clear
.Font.Name = Sheets(Primo).Range(Lay0).Font.Name
.Font.Size = Sheets(Primo).Range(Lay0).Font.Size
End With
'Calcoli preliminari
LastP = Sheets(Primo).Cells(Rows.Count, myKey).End(xlUp).Row
LastS = Sheets(Secondo).Cells(Rows.Count, myKey).End(xlUp).Row
PArr = Sheets(Primo).Range(Lay0).Resize(LastP, LayLargh).Value
SArr = Sheets(Secondo).Range(Lay0).Resize(LastS - Range(Lay0).Row + 1, LayLargh + 1).Value
KArr = Sheets(Secondo).Range(Lay0).Resize(LastP - Range(Lay0).Row + 1, 1).Value
'Confronta 1 con 2
For I = LBound(PArr, 1) To UBound(PArr, 1)
If PArr(I, myKey) <> "" Then 'Ignora se Cod Agenzia vuoto
my2Ag = Application.Match(PArr(I, myKey), KArr, 0)
If IsError(my2Ag) Then
Call MisP(I, 1) 'manca riga in SArr
Else
SArr(my2Ag, UBound(SArr, 2)) = SArr(my2Ag, UBound(SArr, 2)) + 1
For I2 = LBound(PArr, 2) To UBound(PArr, 2)
If PArr(I, I2) <> SArr(my2Ag, I2) Then
Call MisM(I, my2Ag) 'Mismatch tra celle
Exit For
End If
Next I2
End If
End If
Next I
'Check mark su ogni SArr
For I = LBound(SArr, 1) To UBound(SArr, 1)
If SArr(I, myKey) <> "" Then
If SArr(I, UBound(SArr, 2)) <> 1 Then
Call MisS(I, 2) 'manca riga in PArr o MultiMark
End If
End If
Next I
'
End Sub
Sub MisP(RigaMiss, SorgArr As Long)
'Cod Ag in Primo ma mancante su Secondo
LastRep = Sheets(Report).Cells(Rows.Count, 3).End(xlUp).Row + 1
myHLink = Primo & "!" & Cells(RigaMiss + 2 - LBound(PArr, 1), 1).Address
With Sheets(Report)
For I = LBound(PArr, 2) To UBound(PArr, 2)
.Cells(LastRep, 3 + JJ) = PArr(RigaMiss, I)
JJ = JJ + 1
Next I
.Cells(LastRep, 3).Resize(1, JJ + 1).Interior.Color = RGB(222, 111, 0)
'
'inserisci hyperlink
.Hyperlinks.Add Anchor:=.Cells(LastRep, SorgArr), Address:="", SubAddress:= _
myHLink, TextToDisplay:="Vedi 1"
'
End With
End Sub
Sub MisS(RigaMiss, SorgArr As Long)
'Cod Ag in Secondo ma mancante su Primo
LastRep = Sheets(Report).Cells(Rows.Count, 3).End(xlUp).Row + 1
myHLink = Secondo & "!" & Cells(RigaMiss + 2 - LBound(PArr, 1), 1).Address
With Sheets(Report)
For I = LBound(SArr, 2) To UBound(SArr, 2)
.Cells(LastRep, 3 + JJ) = SArr(RigaMiss, I)
JJ = JJ + 1
Next I
.Cells(LastRep, 3).Resize(1, JJ + 1).Interior.Color = RGB(111, 222, 0)
'
'inserisci hyperlink
.Hyperlinks.Add Anchor:=.Cells(LastRep, SorgArr), Address:="", SubAddress:= _
myHLink, TextToDisplay:="Vedi 2"
'
End With
End Sub
Sub MisM(RigaP As Long, RigaS)
'mismatch di celle
LastRep = Sheets(Report).Cells(Rows.Count, 3).End(xlUp).Row + 1
With Sheets(Report)
JJ = 0
For I = LBound(PArr, 2) To UBound(PArr, 2)
.Cells(LastRep, 3 + JJ) = PArr(RigaP, I) & Chr(10) & SArr(RigaS, I)
.Cells(LastRep, 3 + JJ).ColumnWidth = Sheets(Primo).Cells(LastRep, 1 + JJ).ColumnWidth
If PArr(RigaP, I) <> SArr(RigaS, I) Then
.Cells(LastRep, 3 + JJ).Interior.Color = RGB(222, 222, 0)
Else
.Cells(LastRep, 3 + JJ).Interior.Color = xlNone
End If
JJ = JJ + 1
Next I
'inserisci hyperlinks
.Hyperlinks.Add Anchor:=.Cells(LastRep, 1), Address:="", SubAddress:= _
Primo & "!" & Cells(RigaP + 2 - LBound(PArr, 1), 1).Address, TextToDisplay:="Vedi 1"
.Hyperlinks.Add Anchor:=.Cells(LastRep, 2), Address:="", SubAddress:= _
Secondo & "!" & Cells(RigaS + 2 - LBound(PArr, 1), 1).Address, TextToDisplay:="Vedi 2"
End With
End Sub
Flash30005 ha scritto:Mi domandavo perché colorare le righe e non lasciare solo le righe interessate? es.
foglio3 solo quelle che erano nel vecchio catalogo e non più nel nuovo
foglio4 solo prodotti che sono stati aggiunti nel nuovo
(queste righe potrebbero tornare utili per ulteriori utilizzi)
allora ho creato una macro che ha questa funzione
- Codice: Seleziona tutto
Sub Confronta()
' Foglio1 Vecchio Catalogo
' Foglio2 Nuovo Catalogo
' Foglio3 Prodotti che non sono più nel nuovo catalogo
' Foglio4 Nuovi prodotti (non erano nel vecchio catalogo)
Call CopiaF
URS = Worksheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row '<<<< alias Foglio3
URA = Worksheets("Foglio2").Range("A" & Rows.Count).End(xlUp).Row '<<< alias Foglio4
For RS = 2 To URS
For RA = URA To 2 Step -1
If Worksheets("Foglio1").Cells(RS, 1).Value = Worksheets("Foglio4").Cells(RA, 1).Value Then Worksheets("Foglio4").Rows(RA & ":" & RA).Delete
Next RA
Next RS
For RA = 2 To URA
For RS = URS To 2 Step -1
If Worksheets("Foglio2").Cells(RA, 1).Value = Worksheets("Foglio3").Cells(RS, 1).Value Then Worksheets("Foglio3").Rows(RS & ":" & RS).Delete
Next RS
Next RA
End Sub
Sub CopiaF()
Sheets("Foglio3").Select
Cells.Select
Selection.Clear
Range("D10").Select
Sheets("Foglio4").Select
Cells.Select
Selection.Clear
Range("A1").Select
Sheets("Foglio1").Select
Cells.Select
Selection.Copy
Sheets("Foglio3").Select
Cells.Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Foglio2").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Foglio4").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Foglio3").Select
End Sub
Se intendi colorarle allora puoi usare questa macro (la macro CopiaF è sempre necessaria)
- Codice: Seleziona tutto
Sub ConfrontaEColora()
' Foglio1 Vecchio Catalogo
' Foglio2 Nuovo Catalogo
' Foglio3 Prodotti che non sono più nel nuovo catalogo
' Foglio4 Nuovi prodotti (non erano nel vecchio catalogo)
Call CopiaF
URS = Worksheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row '<<<< alias Foglio3
UCS = Worksheets("Foglio1").Range("IV2").End(xlToLeft).Column
Worksheets("Foglio3").Select
Worksheets("Foglio3").Range(Cells(2, 1), Cells(URS, UCS)).Interior.ColorIndex = 44
URA = Worksheets("Foglio2").Range("A" & Rows.Count).End(xlUp).Row '<<< alias Foglio4
UCA = Worksheets("Foglio2").Range("IV2").End(xlToLeft).Column
Worksheets("Foglio4").Select
Worksheets("Foglio4").Range(Cells(2, 1), Cells(URA, UCA)).Interior.ColorIndex = 6
For RS = 2 To URS
For RA = URA To 2 Step -1
If Worksheets("Foglio1").Cells(RS, 1).Value = Worksheets("Foglio4").Cells(RA, 1).Value Then Worksheets("Foglio4").Rows(RA & ":" & RA).Interior.ColorIndex = 0
Next RA
Next RS
For RA = 2 To URA
For RS = URS To 2 Step -1
If Worksheets("Foglio2").Cells(RA, 1).Value = Worksheets("Foglio3").Cells(RS, 1).Value Then Worksheets("Foglio3").Rows(RS & ":" & RS).Interior.ColorIndex = 0
Next RS
Next RA
End Sub
Ambedue le macro prevedono una testata nella riga 1 che non verrà processata
e fanno il confronto solo prendendo in esame il valore nella colonna A (suppongo Codice Prodotto), oltre a poter variare la colonna di confronto puoi aggiungere ulteriori condizioni (altre colonne) affinché il valore di confronto diventi univoco.
Fai sapere
Ciao
Sub TrascriviNuovi()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim FA As Worksheet
Dim FB As Worksheet
Dim FC As Worksheet
Dim myMatch
Set FA = Sheets("Foglio1")
Set FB = Sheets("Foglio2")
Set FC = Sheets("Foglio3")
FC.Cells.Clear
UR1 = FA.Range("A" & Rows.Count).End(xlUp).Row
UR2 = FB.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 1 To UR2
myMatch = Application.Match(FB.Range("A" & RR2), FA.Range("A1:A" & UR1), 0)
If Not IsError(myMatch) Then
Else
UR3 = FC.Range("A" & Rows.Count).End(xlUp).Row + 1
FB.Rows(RR2).Copy Destination:=FC.Rows(UR3)
End If
Next RR2
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Torna a Applicazioni Office Windows
Macro che scatta quando cambia dato in un altro file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 14 |
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 10 |
Modifica visualizzazione file di una cartella Autore: mastino46 |
Forum: Sistemi Operativi Windows Risposte: 2 |
Problema con macro copia e rinomina file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 88 ospiti