unione listini

Hai un problema con Excel?

Nuova discussione

unione listini
di Antonio (utente non iscritto) data: 17/03/2014 12:37:45
Salve, avrei un piccolo problemino:
Ho due listini (listino A e Listino B) nei rispettivi fogli 1 e 2, vorrei creare una macro per effetture l'unione in un unico listino (listino C) nel foglio 3.
I due listini sono costituiti da circa 365000 prodotti suddivisi in 3 colonne (colonna A - Ean, colonna B - titolo prodotto; colonna C - prezzo), vorrei che questa macro nel caso trovasse dei prodotti con lo stesso ean prendesse il prodotto/intera riga con il prezzo più basso.

Esempio

Listino A (foglio 1)

Colonna A (ean) Colonna B (titolo) Colonna C (prezzo)
0000012 prodotto 1 15
00000054 prodotto 5 7
450000005 prodotto 9 9,5

Listino B (foglio 2)

Colonna A (ean) Colonna B (titolo) Colonna C (prezzo)
0000012 prodotto 1 12
00000054 prodotto 5 9
400000005 prodotto 15 100,5
00000087 prodotto 3 87

Vorrei che la macro creasse tale listino C nel foglio 3

Colonna A (ean) Colonna B (titolo) Colonna C (prezzo)
00000054 prodotto 5 7 ------------ (preso dal listino A in quanto a parità di ean ha il prezzo più basso)
450000005 prodotto 9 9,5 ----------- (preso dal listino A in quanto non ha nessun ean coincidente )
0000012 prodotto 1 12 ---------- (preso dal listino B in quanto a parità di ean ha il prezzo più basso )
400000005 prodotto 15 100,5 ---------- (preso dal listino B in quanto non ha nessun ean coincidente )
00000087 prodotto 3 87 ---------- (preso dal listino B in quanto non ha nessun ean coincidente )

Vi Ringrazion in anticipo

Antonio

di Raffaele_53 (utente non iscritto) data: 17/03/2014 13:30:45
Dovrebbe funzionare

Option Explicit
Sub Unione()
Dim sh1 As Worksheet: Set sh1 = Sheets("Foglio1") ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = Sheets("Foglio2") ' da cambiare casomai
Dim sh3 As Worksheet: Set sh3 = Sheets("Foglio3") ' da cambiare casomai
Dim Area2 As Range
Dim Uriga1 As Long, Uriga2 As Long, RR As Long, X As Long, R As Long
Dim Nome As String, Riga As Object, Prezzo1 As Double, Prezzo2 As Double
Uriga1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
Uriga2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
Set Area2 = sh2.Range("A2:A" & Uriga2)
RR = 2
    For X = 2 To Uriga1
        Nome = sh1.Cells(X, 1)
        Prezzo1 = sh1.Cells(X, 3)
        Set Riga = Area2.Find(Nome, LookIn:=xlValues, LookAt:=xlWhole)
            If Riga Is Nothing Then
                        sh1.Range(sh1.Cells(X, 1), sh1.Cells(X, 3)).Copy
                        sh3.Cells(RR, 1).PasteSpecial
                        RR = RR + 1
            Else
                R = Riga.Row
                Prezzo2 = sh2.Cells(R, 3)
                    If Prezzo1 <= Prezzo2 Then
                        sh1.Range(sh1.Cells(X, 1), sh1.Cells(X, 3)).Copy
                        sh3.Cells(RR, 1).PasteSpecial
                        RR = RR + 1
                    Else
                        sh2.Range(sh2.Cells(R, 1), sh2.Cells(R, 3)).Copy
                        sh3.Cells(RR, 1).PasteSpecial
                        RR = RR + 1
                    End If
            End If
    Next X
    Set Area2 = sh1.Range("A2:A" & Uriga1)
    For X = 2 To Uriga2
        Nome = sh2.Cells(X, 1)
        Set Riga = Area2.Find(Nome, LookIn:=xlValues, LookAt:=xlWhole)
            If Riga Is Nothing Then
                        sh2.Range(sh2.Cells(X, 1), sh2.Cells(X, 3)).Copy
                        sh3.Cells(RR, 1).PasteSpecial
                        RR = RR + 1
            End If
    Next X
Set sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing
MsgBox "Fatto"
End Sub

di totygno71 (utente non iscritto) data: 17/03/2014 14:14:58
Altro metodo.

Option Explicit
Sub togli()
Dim ur1 As Long, ur2 As Long, ur3 As Long

Sheets(3).Cells.ClearContents

ur1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
ur2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row

Sheets(1).Range("A1:C" & ur1).Copy Sheets(3).Range("A1")

ur3 = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row

Sheets(2).Range("A2:C" & ur2).Copy Sheets(3).Range("A" & ur3 + 1)

ur3 = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row

Sheets(3).Range("$A$1:$C$" & ur3).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

di totygno71 (utente non iscritto) data: 17/03/2014 14:16:49
Non ho letto bene la richiesta, del prezzo più basso. chiedo venia! :(
di Antonio (utente non iscritto) data: 17/03/2014 18:49:34
grazie mille per avermi risposto!!!

piccolo problema, nella cella c'è il numero quindi quando vado a cliccare appare il numerocella/100 è possibile in qualche modo far apparire il solo numero senza "formula"?

grazie ancora!!!
di Raffaele_53 (utente non iscritto) data: 17/03/2014 19:09:18
Hai delle formule in foglio1,foglio2 ???

Modifica le tre righe = sh3.Cells(RR, 1).PasteSpecial in
sh3.Cells(RR, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
di Vecchio Frac data: 17/03/2014 19:09:49
Ti basta consolidare il dato così:
cella.Value = cella.Value
(dove chiaramente "cella" è la cella con la formula che vuoi consolidare)
Sembra una cosa strana ma lo è ^_^
unione listini
di Antonio (utente non iscritto) data: 17/03/2014 20:26:48
Salve, ho effettutato la macro indicato da Raffaele e funziona benissimo solo che avendo 365000 prodotti, è un po lento, c'è modo di velocizzare la macro?

Grazie a tutti per la risposta

Antonio
unione listini
di Antonio (utente non iscritto) data: 17/03/2014 20:54:47
Salve, un'altra piccola domanda, anzieche importare solo le colonne A B C, se avessi anche altre colonne (fino a z), come posso modificare la macro indicando che mi deve importare anche le restanti colonne con lo stesso criterio.

Antonio

Grazie
di Raffaele_53 (utente non iscritto) data: 18/03/2014 01:04:48
Sino alla colonna Z devi modificare le 4 stringhe in
sh1.Range(sh1.Cells(X, 1), sh1.Cells(X, 26)).Copy
Attenzione due sono sh1 e due con sh2

Per la velocita non lo saprei. Bisognerebbe trovare un'altro metodo
Quale tra foglio1 e foglio2 ha meno record?
uniione listini
di Antonio (utente non iscritto) data: 18/03/2014 11:24:38
Ciao Raffaele, ho provato ed è perfetto arriva fino alla colonna Z, solo che è lento comunque il listino che ha meno prodotti e il primo quello del foglio 1

Antonio

Grazie

di totygno71 (utente non iscritto) data: 18/03/2014 12:47:20
Vediamo se ho dimenticato qualche altro particolare ^_^

Option Explicit
Sub togli()
Dim ur1 As Long, ur2 As Long, ur3 As Long
Dim c  As Range, xcell As Range
Dim stringa As String, i As Long

Sheets(3).Cells.ClearContents
Application.ScreenUpdating = False
ur1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
ur2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row


Sheets(1).Range("A1:Z" & ur1).Copy Sheets(3).Range("A1")

ur3 = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row

Sheets(2).Range("A2:Z" & ur2).Copy Sheets(3).Range("A" & ur3 + 1)

ur3 = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row

Sheets(3).Activate
For i = 2 To ur3

stringa = Cells(i, 1).Value
If stringa = "" Then Exit For
Set xcell = Sheets(3).Range(Cells(i + 1, 1), Cells(ur3, 1)).Find(What:=stringa, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

If Not xcell Is Nothing Then
    If Cells(i, 1).Offset(, 2) >= xcell.Offset(, 2) Then
    Cells(i, 1).EntireRow.Delete
    Else
    xcell.EntireRow.Delete
    End If
End If
Next i

Application.ScreenUpdating = True
MsgBox "Fatto"

End Sub

di Raffaele_53 (utente non iscritto) data: 18/03/2014 18:56:07
Ciao totygno71, col Tuo modo deve essere più veloce per forza.

Credo però che devi aggiungere una riga
If Not xcell Is Nothing Then
If Cells(i, 1).Offset(, 2) >= xcell.Offset(, 2) Then
Cells(i, 1).EntireRow.Delete
>>> i = i - 1
Else

Altro modo potrebbe essere di copiare solo il foglio2, dopo tramite Find analizzare il foglio1 (come ha scritto quello con meno record)

di Raffaele_53 (utente non iscritto) data: 18/03/2014 20:00:48
Ti allego altro codice da provare.
Anche se il codice di totygno71 è più veloce 0,0625 contro 0,078125
Non saprei come migliorarlo?

Questo copia il foglio2, dopo analizza i record del foglio1 scrivendoli oppure inserendo il prezzo più basso in foglio3

Option Explicit
Sub Unione()
Dim sh1 As Worksheet: Set sh1 = Sheets("Foglio1") ' da cambiare casomai
Dim sh2 As Worksheet: Set sh2 = Sheets("Foglio2") ' da cambiare casomai
Dim sh3 As Worksheet: Set sh3 = Sheets("Foglio3") ' da cambiare casomai
Dim Area3 As Range
Dim Uriga1 As Long, Uriga2 As Long, RR As Long, X As Long, R As Long
Dim Nome As String, Riga As Object
Dim T As Single ' calcola tempo
T = Timer ' calcola tempo
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
sh3.Cells.ClearContents
Uriga1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
Uriga2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
sh2.Range(sh2.Cells(2, 1), sh2.Cells(Uriga2, 26)).Copy
sh3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Set Area3 = sh3.Range("A2:A" & Uriga2)
RR = Uriga2 + 1
    For X = 2 To Uriga1
        Nome = sh1.Cells(X, 1)
        Set Riga = Area3.Find(Nome, LookIn:=xlValues, LookAt:=xlWhole)
            If Riga Is Nothing Then
                        sh1.Range(sh1.Cells(X, 1), sh1.Cells(X, 26)).Copy
                        sh3.Cells(RR, 1).PasteSpecial
                        RR = RR + 1
            Else
                R = Riga.Row
                    If sh1.Cells(X, 3) < sh3.Cells(R, 3) Then
                        sh3.Cells(R, 3) = sh1.Cells(X, 3)
                    End If
            End If
    Next X
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Unione complettata in :" & " " & Timer - T & " " & " minuti/secondi" ' calcola tempo
Set sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing
End Sub

di mb data: 19/03/2014 14:28:22
complimenti a tutti

per perfezionare ancora un pò il prospetto si potrebbe aggiungere a fianco del prezzo il nome del foglio per sapere in quale dei due si trova il prezzo più basso

ciao e scusate il disturbo
di Raffaele_53 (utente non iscritto) data: 19/03/2014 15:30:41
Aggiunta di due/tre secondi.
Dopo la riga >>>sh3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Puoi mettere >>>sh3.Range("AA2:AA" & Uriga2) = "Foglio2" (scegli Tu dove sia meglio)

Non lo faccio per il foglio1 dato che dovrei fare altre operazioni. Mi sembra che sia già lento.
di Antonio (utente non iscritto) data: 21/03/2014 10:01:47
grazie ragazzi funziona benissimo!
di mb data: 21/03/2014 10:36:39
buongiorno
chiedo umilmente scusa a raffaele perchè rispondo solo adesso
sicuramente mi sono spiegato male io nella segnalazione precedente
supponiamo che in riga 4 del foglio 1 ho il prezzo più basso .
nel foglio3 in cella AA... dovrebbe scrivere foglio1 mentre la procedura segnalata segna sempre foglio2..

grazie

sicuramente non ho capito io come adattarlo al file
sh3.Range("AA2:AA" & Uriga2) = "foglio2"

di Raffaele_53 (utente non iscritto) data: 21/03/2014 16:12:28
Ho sbagliato l'ultima risposta.
OK mettere l'aggiunta di due/tre secondi sh3.Range("AA2:AA" & Uriga2) = "Foglio2" (scegli Tu dove sia meglio)

Anche vero che nel codice bisogna aggiungere una riga per quando si analizza il foglio1 Cells(27) equivale alla colonna AA

Else
                R = Riga.Row
                    If sh1.Cells(X, 3) < sh3.Cells(R, 3) Then
                        sh3.Cells(R, 3) = sh1.Cells(X, 3)
        ---------->sh3.cells(R,27) = "Foglio1"
		End If

Vuoi Approfondire?