Excel 2007 Elimina colonne identiche in più fogli

[max2011]

Salve,
avrei bisogno di una macro che mi eliminassi le colonne multiple identiche che si trovano in matrici suddivise in più fogli( identiche si intendono uguali anche come disposizione numerica). La macro dovrebbe trovare le colonne identiche e eliminarle, quindi lasciarne solo una, non deve fare altro. Non deve mettere in ordine solo trovare e eliminare.
PS. La macro dovrebbe considerare da il range da B2:AL38 cioè non considerare i numeri in rosso.
Posto un file con 20 fogli ma dovrebbe farlo su centinaia

http://www.filedropper.com/esempioeliminacolonneuguali

Esempio:

Foglio 1 colonna 15
Foglio 8 colonna 13
Foglio 14 colonna 37 sono uguali quindi cancellare 2 colonne

Foglio 7 colonna 2
Foglio 16 colonna 8 sono uguali quindi cancellare 1 colonna

Grazie di tutto

[Anthony47]

Posso provarci, pero' il collaudo lo fai tu...
Si trattera' di una semplice sequenza di For /Next, che potrebbe durare "qualche minuto"; volendo velocizzare, ci sono strutture fisse, tipo sempre 37 colonne per ogni foglio e sempre 37 righe per colonna? Si tratta sempre di numeri? Valori minimo e max? Possiamo dire che avrai meno di 500 fogli?

Ciao

[max2011]

Ciao Anthony47 e grazie per l'interessamento.

Sono solo numeri
Le tabelle sono sempre uguali come hai visto. 37x37
I numeri sono da 0 a 36 messi sparsi
I fogli sarebbero 504, ma se ci sono problemi, ne faccio 499 e poi ne faccio altri

Grazie ancora

[ricky53]

Ciao,
per semplificare i controlli e, quindi, il codice: nello stesso foglio ci possono essere colonne uguali ???
Mi aspetto "NO" come risposta.

[max2011]

Salve ricky53,
nello stesso foglio non ci possono essere colonne uguali.

Grazie per l'interessamento

[ricky53]

Bene.
Sto facendo delle prove con il fiel che hai inviato.

Al momento a me risultano:
A) colonna 13 del foglio 8 uguale alla colonna 15 del foglio 1

B) colonna 37 del foglio 14 uguale alla colonna 15 del foglio 1

Confermi ???

[max2011]

Salve,
si confermo.

Grazie ancora

[ricky53]

Ciao,
si avevo visto i dati che avevi inserito tu all'inzio dell tua discussione ma ... è meglio essere certi ... due volte.

Adesso aggiungo:
A) colonna 8 del foglio 16 uguale alla colonna 2 del foglio 7

B) colonna 37 del foglio 14 uguale alla colonna 13 del foglio 8

Non ho trovato altri casi di uguaglianze.


Forse ho finito di redigere il codice, un po' di test e ... a più tardi per il codice.

[ricky53]

Ciao,
ecco il codice

Codice: Seleziona tutto

Option Explicit
Option Base 1

Sub Elimina_Colonne_Uguali()
    Dim Vett_A(), Vett_B(), Vett_C()
    Dim I As Integer, J As Integer, K As Integer, Uguali As Integer, Inizio As Long
    Dim Ws1 As Worksheet, Ws2 As Worksheet, Sh As Integer, Sh_A As Integer, Messaggio As String, Cancellate As Integer
   
    ReDim Vett_C(37, 37)
   
    Application.ScreenUpdating = False
    Inizio = Timer
    Cancellate = 0: Messaggio = ""
    For Sh_A = 1 To Worksheets.Count
        Set Ws1 = Sheets(Sh_A)
        Vett_A = Ws1.Range("B2:AL38")

' Traspone la Matrice
        For I = 1 To 37
            For J = 1 To 37
                Vett_C(J, I) = Vett_A(I, J)
            Next J
        Next I
        Vett_A = Vett_C
       
        For Sh = Sh_A + 1 To Worksheets.Count
            ReDim Vett_C(37, 37)
            Set Ws2 = Sheets(Sh)
            Vett_B = Ws2.Range("B2:AL38")

' Traspone la Matrice
            For I = 1 To 37
                For J = 1 To 37
                    Vett_C(J, I) = Vett_B(I, J)
                Next J
            Next I
            Vett_B = Vett_C
       
            For I = 37 To 1 Step -1 ' Scorre le colonne della Matrice
                For K = 37 To 1 Step -1
                    Uguali = 0
                    For J = 1 To 37 ' Scorre le righe della Matrice
                        If Vett_A(I, J) = Vett_B(K, J) Then
                            Uguali = Uguali + 1
                        End If
                    Next J
                    If Uguali = 37 Then

'...................................................................................
' Togli l'apice alla seguente istruzione per cancellare effettivamente le colonne
'                    Columns(K + 1).Delete
'...................................................................................
                       
                        Messaggio = Messaggio & vbCrLf & vbCrLf & "Cancellata la colonna " & K & "  del Foglio  " & Sh _
                            & "  che è uguale alla colonna " & I & "  del Foglio  " & Sh_A
                        Cancellate = Cancellate + 1
                    End If
                Next K
            Next I
        Next Sh
    Next Sh_A
    Application.ScreenUpdating = True
   
    If Cancellate > 0 Then
        Messaggio = Messaggio & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "In totale sono state cancellate  " & Cancellate & "  colonne impiegando (h.mm.ss)   " & Format((Timer - Inizio) / 1440, "h.mm.ss")
    Else
        Messaggio = "NON sono state cancellate colonne"
    End If
    MsgBox Messaggio
    Set Ws1 = Nothing: Set Ws2 = Nothing
End Sub

Copia ed esegui la macro senza toccare nulla: è una prova non cancella nessuna colonna.

Dopo i controlli vai nel codice e togli l'apice dove l'ho scritto.
L'istruzione da far eseguire è

Codice: Seleziona tutto

'                    Columns(K + 1).Delete

devi togliere l'apice e rieseguire la macro

Prova e ... sono QUI

[max2011]

Ho tolto l'apice ma non cancella le colonne

[ricky53]

Ciao,
hai provato sul file che hai inviato tu?

Hai fatto la prova come ti ho detto senza togliere l'apice?
Che risultati hai ottenuto?

[max2011]

Ciao,
ho provato su quel file, esce la scritta, ma non cancella niente

[max2011]

B) colonna 37 del foglio 14 uguale alla colonna 13 del foglio 8 e alla colonna 15 del foglio 1, Ne deve cancellare 2

[ricky53]

Ciao,
controlla di aver effettivamente tolto l'apice all'istruzione che ti ho indicato !
Hai rieseguito la macro ?
Quanto tempo ha impegato ?

Se non cancella invia il file con la macro inserita e provo io.

[max2011]

http://www.filedropper.com/esempioelimi ... gualimacro

[max2011]

A) colonna 8 del foglio 16 uguale alla colonna 2 del foglio 7

B) colonna 37 del foglio 14 uguale alla colonna 13 del foglio 8 e alla colonna 15 del foglio 1, Ne deve cancellare 2

[ricky53]

Ciao,
nel sistemare il codice non ho riportato l'istruzione corretta.
Eccola

Codice: Seleziona tutto

Sheets(Sh).Columns(K + 1).Delete

che va a sostituire

Codice: Seleziona tutto

Columns(K + 1).Delete

che è errata
SORRY !!!

Mi fai sapere che tempi hai sia con il file ridotto che con quello iniziale.

[max2011]

Cancellata la colonna 8 del foglio 16 che è uguale alla colonna 2 del foglio 7 ( OK )

Cancellata la colonna 37 del foglio 14 che è uguale alla colonna 13 del foglio 8 ( Questa va bene ma ne dovrebbe cancellare 2 di colonne, c'è anche colonna 15 del foglio 1 )

Cancellata la colonna 37 del foglio 16 che è uguale alla colonna 37 del foglio 14 ( Questa non dovrebbe cancellarla ) perchè non è uguale

Grazie 1000 per l'aiuto che mi stai dando

[ricky53]

Ciao,
la 15 del foglio 1 non deve rimanere? Almeno una ?

A me la colonna 37 del foglio 16 non la segnala come cancellata.

[max2011]

Si deve rimanere una colonna