[Excel]Macro Trova-Copia-Incolla

[Jack09]

Buonasera a tutti!
Sono nuovo del forum e mi rivoglo a voi per un piccolo aiuto sulle macro visto che sono anche un loro neofita
La situazione è questa ho un file con 2 fogli, in ognuno colonne di dati solo che nel secondo queste (le colonne) non sono ordinate come vorrei quindi la macro dovrebbe individuare nella prima riga del foglio 2 quale cella contiene il testo "x" copiare i dati della rispettiva colonna ed incollarli nel foglio uno nella cella C2 (ad esempio).
Ho provato a cercare qualcosa in rete ed adattarlo ma non sembra funzionare copio ed incollo comunqe:

Sub CopySignificant()
'Copy cells of cols A,F,E,D from rows containing "Significant" in
'col D of the active worksheet (source sheet) to cols
'A,B,C,D of Sheet2 (destination sheet)
Sheets("Sheet1").Select
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1

For sRow = 1 To Range("D65536").End(x1Up).Row
'use pattern matching to find "Significant" anywhere in cell
If Cells(sRow) Like "*BAR*" Then
sCount = sCount + 1
dRow = dRow
'copy cols A,F,E & D
Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, "A")
Cells(sRow + 2, "C").Copy Destination:=DestSheet.Cells(dRow, "B")
Cells(sRow + 3, "D").Copy Destination:=DestSheet.Cells(dRow, "C")
Cells(sRow + 4, "E").Copy Destination:=DestSheet.Cells(dRow, "D")
End If
Next sRow

MsgBox sCount & " Columns rows copied", vbInformation, "Transfer Done"

End Sub

Grazie in anticipo!

[Anthony47]

Ciao Jack09 e benvenuto nel forum.
Non ho capito bene la richiesta: vuoi modificare l' ordine delle colonne del Foglio2? E quale e' la sequenza delle colonne che vuoi ricreare?
Se non l' ho proprio indovinata allora, come vedi, vuol dire che devi spiegare il problema da risolvere con un po' piu' di "dettagli".

Ciao, fatti sentire.

[Jack09]

Buongiorno Anthony47, si praticamente dovrebbe fare un copia ed incolla delle colonne nel foglio 2 in un altro ordine sul foglio1, il fatto è che deve riconoscere quale colonna del foglio2 va in una determinata colonna del foglio2 in quante l'ordine dell prime cambia.
Vediamo se riesco a rendere l'idea graficamente:
A B C A B C
1 Alfa Beta Gamma 1 Gamma Alfa Beta
2 2 0 1 2
3 3 0 1 2
4 4 0 1 2
(foglio1) (foglio2)

Lancio la macro:

A B C A B C
1 Alfa Beta Gamma 1 Gamma Alfa Beta
2 1 2 0 2 0 1 2
3 1 2 0 3 0 1 2
4 1 2 0 4 0 1 2
(foglio1) (foglio2)

[Jack09]

ti metto il link all'immagine è meglio:
http://www.freefilehost.co.uk/586198

la password è: macro

[Flash30005]

Ciao Jack

Prova a vedere se questa macro ti soddisfa

Codice: Seleziona tutto

Sub CopiaOrdine()
UC1 = Worksheets("Foglio1").Range("A1").End(xlToRight).Column
UC2 = Worksheets("Foglio2").Range("A1").End(xlToRight).Column
UR = Worksheets("Foglio2").Range("A" & Rows.Count).End(xlUp).Row
For I1 = 1 To UC1
    Testata1 = Worksheets("Foglio1").Cells(1, I1).Value
    For I2 = 1 To UC2
        Testata2 = Worksheets("Foglio2").Cells(1, I2).Value
        If Testata1 = Testata2 Then
            Worksheets("Foglio2").Select
            Range(Cells(2, I2), Cells(UR, I2)).Select
            Selection.Copy
            Worksheets("Foglio1").Select
            Cells(2, I1).Select
            ActiveSheet.Paste
            Range("A1").Select
        End If
    Next I2
Next I1
End Sub

Nella riga 1 da A a.... nColonne devono esserci gli stessi testi sia nel foglio1 che nel foglio2 anche se in ordine diverso
Per nColonne intendo tutte quelle che il foglio prevede (256 per office2003)

Fai sapere
Ciao

[Jack09]

Grazie Flash per l'aiuto, sembra girare ma:

- copia solo la prima colonna tralasciando le altre nonostante abbiano lo stesso valore nella riga 1
- se provo a spostare la prima colonna non va più

[Anthony47]

Se in riga 1 le intestazioni non sono contigue (cioe' ci sono delle celle vuote tra le intestazioni valide), allora cambia queste
UC1 = Worksheets("Foglio1").Range("A1").End(xlToRight).Column
UC2 = Worksheets("Foglio2").Range("A1").End(xlToRight).Column
in queste

Codice: Seleziona tutto

UC1 = Worksheets("Foglio1").Cells(1, Columns.count).End(xlToleft).Column
UC2 = Worksheets("Foglio2").Cells(1, Columns.count).End(xlToleft).Column


Ciao.

[Jack09]

!grazie mille!
ora devo fare lo stesso per le altre colonne in modo che lo faccia per tutte con la stessa macro....
spero di riuscirci da solo

[Flash30005]

...ora devo fare lo stesso per le altre colonne in modo che lo faccia per tutte con la stessa macro....

Le variabili UC1 e UC2 determinano il numero di colonne con dati (nella riga1) sia del foglio1 che del foglio2 e non occorre determinare altro (o altre colonne).
Nel caso da te inviato il numero di colonne è pari a 3 (Alfa, Beta, Gamma), quindi suppongo che ciò che hai postato non corrisponda alla effettiva impostazione che hai nella testata in quanto la macro funziona perfettamente anche con 200 colonne.
Potresti inviare un'imagine del foglio (o testata) reale?

Ciao

[Jack09]

Ciao flash, ecco il link del file originale
http://www.freefilehost.co.uk/372276
password: pcfacile

praticamente le testate del foglio 2 hanno dei numeri davanti, dunque i valori di quella colonna deovno andare nella colonna del foglio 1 che ha nella cella di testata il numero corrispettivo, vale lo stesso discorso per il foglio 3 solo che la testata non ha un numero ma un valore di testo.

è un po complicato....spero di essere stato chiaro

Ti ringrazio veramente tanto per la disponibilità

[Flash30005]

Vedo un po' caotica l'impostazione del "resoconto" foglio1 e foglio3 rispetto al foglio2 quest'ultimo, penso, provenga da un file testo prodotto da un programma acquisizione dati automatico o manuale.

Iniziamo:
1) nel foglio1 cella B1 vedo scritto 10, 25, 11, 12, 14 e 33 presumo che a parità di numero (iniziale) della testata del foglio2 i dati dovranno essere riportati qui, quindi la colonna D che ha come testata "10-RACK HIGH" si dovrà prendere solo il 10 come filtro (gli altri numeri non sono riproposti, ? ), ma in C2:C32 del foglio1 che ha come testata "BAR" cosa dovrebbe esserci riportato (visto che Bar non esiste come testata nel foglio2)?

2) nel foglio1 cella E1 ci sono 29, 24, 20, 28, 21, 22 e 23, nel foglio2 esistono solo 28 e 23 in questo caso cosa si deve fare? Sommare i due valori per riga? Inoltre in F "Business Individual" quali valori vanno inseriti?

3) nel foglio3 le testate sono completamente diverse dalle testate del foglio2 come pensi sia possibile trovare i riferimenti? (Es. Foglio3 Testata = Fit, valore F2 = 23, tutti i "Fit" del foglio2 danno come somma un valore = 1 come hai ottenuto 23?)

Una soluzione possibile, solo se il foglio2 presenta sempre le stesse colonne negli stessi punti, la si può ottenere con delle formule, esempio:
Nel foglio1 cella K2 (Fit 17, 18) puoi mettere la formula

Codice: Seleziona tutto

=Sheet2!G2+Sheet2!H2

e la copi verso il basso e così via per tutte le correlazioni che hai tra le colonne del foglio1 con il foglio2

Fai sapere
Ciao

[Jack09]

Nel foglio uno c'è uno riorganizzazione realizzata da me mentre come dici tu giustamente nel foglio 2 e 3 ci sono i dati di un programma di automatico


1) nel foglio1 cella B1 vedo scritto 10, 25, 11, 12, 14 e 33 presumo che a parità di numero (iniziale) della testata del foglio2 i dati dovranno essere riportati qui, quindi la colonna D che ha come testata "10-RACK HIGH" si dovrà prendere solo il 10 come filtro (gli altri numeri non sono riproposti, ? ), ma in C2:C32 del foglio1 che ha come testata "BAR" cosa dovrebbe esserci riportato (visto che Bar non esiste come testata nel foglio2)?
1) Esatto, nella celle B2:B32 del Foglio 1 ci va la somma dei valori presenti nelle celle B2:B32 che hanno nella testata uno dei numeri presenti in B2 Foglio1 (i numeri non riproposti);
nelle celle C2:C32 del Foglio1 sotto alla testata "BAR" vanno i valori presenti nel Foglio3 nella medesima colonna con testata "BAR"

2) nel foglio1 cella E1 ci sono 29, 24, 20, 28, 21, 22 e 23, nel foglio2 esistono solo 28 e 23 in questo caso cosa si deve fare? Sommare i due valori per riga? Inoltre in F "Business Individual" quali valori vanno inseriti?
2)Esattamente vanno sommati solo i valori delle colonne presenti poichè la posizione e la presenza o no è variabile;
per Business Individual ti faccio uno schema alla fine per l'aggregazione

3) nel foglio3 le testate sono completamente diverse dalle testate del foglio2 come pensi sia possibile trovare i riferimenti? (Es. Foglio3 Testata = Fit, valore F2 = 23, tutti i "Fit" del foglio2 danno come somma un valore = 1 come hai ottenuto 23?)
3)Il Foglio 2 fa riferimento alle colonne di sx per capirsi quelle con testata numerica nel Foglio1, mentre il Foglio3 a quelle con testata testuale sempre nel Foglio1

Una soluzione possibile, solo se il foglio2 presenta sempre le stesse colonne negli stessi punti, la si può ottenere con delle formule, esempio:
Nel foglio1 cella K2 (Fit 17, 18) puoi mettere la formula
Purtroppo no le colonne variano di posizione e se sono presenti o meno

La corrispondenza è:

Foglio1 Folgio3
BAR -> BAR
B.INDIVIDUAL -> CORPORATE
OTHERS -> SPECIAL, LEISURE, WEB MERCHANT
FIT -> FIT
BUSINESS GROUP -> BUSINESS GROUP
LEISURE GROUP -> LEISURE GROUP
CREW -> CREW
NO REVENUE rimane vuoto

Spero di aver reso l'idea, in effetti è un po complicato

[Flash30005]

Premesso che tu abbia una cartella di lavoro come quella inviato
(a me risultano 3 fogli con i seguenti nomi: sheet1, sheet2 e sheet4)
inserisci in un modulo queste macro

Codice: Seleziona tutto

Sub Riepilogo1()
UC2 = Worksheets("Sheet2").Cells(2, Columns.Count).End(xlToLeft).Column
UR2 = Worksheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row
For CC1 = 2 To 24 Step 3
    Testata1 = Worksheets("Sheet1").Cells(1, CC1).Value
    Testata1 = Trim(Testata1)
    Testata1 = Replace(Testata1, " ", "")
    LTestata1 = Len(Testata1)
    NN = 0
    For N = 1 To LTestata1 Step 2
        Nval1 = Mid(Testata1, N, 2)
        For CC2 = 3 To UC2
            Testata2 = Worksheets("Sheet2").Cells(1, CC2).Value
            Testata2 = Trim(Testata2)
            Nval2 = Mid(Testata2, 1, 2)
            If Nval1 = Nval2 Then
                For RR2 = 2 To UR2
                    Worksheets("Sheet1").Cells(RR2, CC1).Value = Worksheets("Sheet1").Cells(RR2, CC1).Value + Worksheets("Sheet2").Cells(RR2, CC2).Value
                Next RR2
            End If
        Next CC2
    Next N
Next CC1
Call Riepilogo2
End Sub
Sub Riepilogo2()
UC3 = Worksheets("Sheet4").Cells(2, Columns.Count).End(xlToLeft).Column
UR3 = Worksheets("Sheet4").Range("B" & Rows.Count).End(xlUp).Row
For CC3 = 3 To UC3
    Testata4 = Worksheets("Sheet4").Cells(1, CC3).Value
    Testata4 = Trim(Testata4)
    If Testata4 = "CORPORATE" Then Testata4 = "BUSINESS INDIVIDUAL"
    If Testata4 = "SPECIAL" Or Testata4 = "LEISURE" Or Testata4 = "WEB MERCHANT" Then Testata4 = "OTHERS"
    For CC1 = 3 To 24 Step 3
        Testata1 = Worksheets("Sheet1").Cells(1, CC1).Value
        Testata1 = Trim(Testata1)
        If Testata1 = Testata4 Then
            For RR3 = 2 To UR3
                Worksheets("Sheet1").Cells(RR3, CC1).Value = Worksheets("Sheet1").Cells(RR3, CC1).Value + Worksheets("Sheet4").Cells(RR3, CC3).Value
            Next RR3
        End If
    Next CC1
Next CC3
End Sub


Occorre solo avviare Riepilogo1

Fai sapere
Ciao

[Jack09]

Ti ringrazio infinitamente!!!
Un unica cosa la colonna OTHERS è possibile farle prendere un valore di media tra: SPECIAL, LEISURE, WEB MERCHANT
perchè se uno è vuota mi da zero...

[Jack09]

Ti ringrazio infinitamente!!!
Un unica cosa la colonna OTHERS è possibile farle prendere un valore di media tra: SPECIAL, LEISURE, WEB MERCHANT
perchè se uno è vuota mi da zero...

AAAAAAAHHHHHHH!!!!!! ho sbagliato!

Non era quella la serie di dati da inserire!ma quella con lo stesso nome!

[Jack09]

Ecco è questo il file finale molto piu facile dove le testate sono le stesse solo che i valori del foglio "RN" vanno nelle colonne con testata uguale sottocolonna RN e lo stesso per ADR...
come prima nel le testate del Sheet1 uno diverse vanno considerate cosi:
Others(RN) = Web Merchant + Special + Packages per la sottocolonna RN
Others(ADR) = AVERAGE(Web Merchant;Special;Packages) per la sottocolonna ADR
CORPORATE(RN e ADR) = Business Individual per entrambi le sottocolonne

ti allego il file: http://www.freefilehost.co.uk/635613
password: pcfacile

scusami...

[Flash30005]

Ciao Jack
Allora... spero che così vada bene

Codice: Seleziona tutto

Sub RiepilogoRN()
Call CancellaVal
UC2 = Worksheets("RN").Cells(2, Columns.Count).End(xlToLeft).Column
UR2 = Worksheets("RN").Range("B" & Rows.Count).End(xlUp).Row
For CC1 = 2 To 24 Step 3
    Testata1 = Worksheets("Sheet1").Cells(1, CC1).Value
    Testata1 = Trim(Testata1)
        For CC2 = 3 To UC2
            Testata2 = Worksheets("RN").Cells(1, CC2).Value
            Testata2 = Trim(Testata2)
            If Testata2 = "CORPORATE" Then Testata2 = "BUSINESS INDIVIDUAL"
            If Testata2 = "SPECIAL" Or Testata2 = "LEISURE" Or Testata2 = "WEB MERCHANT" Then Testata2 = "OTHERS"
            If Testata1 = Testata2 Then
                For RR2 = 2 To UR2
                    Worksheets("Sheet1").Cells(RR2 + 1, CC1).Value = Worksheets("Sheet1").Cells(RR2 + 1, CC1).Value + Worksheets("RN").Cells(RR2, CC2).Value
                Next RR2
            End If
        Next CC2
Next CC1
Call RiepilogoADR
End Sub
Sub RiepilogoADR()
UC3 = Worksheets("ADR").Cells(2, Columns.Count).End(xlToLeft).Column
UR3 = Worksheets("ADR").Range("B" & Rows.Count).End(xlUp).Row
For CC3 = 3 To UC3
    Testata4 = Worksheets("ADR").Cells(1, CC3).Value
    Testata4 = Trim(Testata4)
    If Testata4 = "CORPORATE" Then Testata4 = "BUSINESS INDIVIDUAL"
    If Testata4 = "SPECIAL" Or Testata4 = "LEISURE" Or Testata4 = "WEB MERCHANT" Then Testata4 = "OTHERS"
    For CC1 = 2 To 24 Step 3
        Testata1 = Worksheets("Sheet1").Cells(1, CC1).Value
        Testata1 = Trim(Testata1)
        If Testata1 = Testata4 Then
            For RR3 = 2 To UR3
                Worksheets("Sheet1").Cells(RR3 + 1, CC1 + 1).Value = Worksheets("Sheet1").Cells(RR3 + 1, CC1 + 1).Value + Worksheets("ADR").Cells(RR3, CC3).Value
            Next RR3
        End If
    Next CC1
Next CC3
For RR3 = 3 To UR3 + 1
Worksheets("Sheet1").Cells(RR3, 9).Value = Worksheets("Sheet1").Cells(RR3, 9).Value / 3
Next RR3
    Worksheets("Sheet1").Range("I3:I33").Select
    Selection.NumberFormat = "0.00"
    Range("B1").Select
End Sub

Sub CancellaVal()
     Worksheets("Sheet1").Select
     Rows("3:33").Select
    Selection.ClearContents
    Range("A1").Select
End Sub


Inoltre nel Foglio "Sheet1" (non nel modulo)
inserisci questo codice

Codice: Seleziona tutto

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = "$B$1:$C$1" Then RiepilogoRN
Cancel = True
End Sub

Che ti permetterà di avviare la macro RiepilogoRN al doppio click del mouse su BAR (B1:C1) del foglio1
Ho inserito anche una macro CancellaVal per eliminare i valori precedenti altrimenti ogni volta il programma somma i nuovi valori ai vecchi se a te occorre aggiungerli allora commenta la riga
Call CancellaVal
così
'Call CancellaVal
nella macro "RiepilogoRN"

Hai parlato di media dei valori nelle colonne

Others(ADR) = AVERAGE(Web Merchant;Special;Packages)

Ho pensato ad una Media aritmetica riga per riga cioè la somma di (riga1) Web Merchant + Special + Package e poi diviso 3, è questo che volevi?

Fai sapere
Ciao

[Jack09]

Perfetto, mancano solo due ritocchi,
-la colonna others non sembra sommare anche la colonna package ne per RN ne per ADR,
-è possibile lasciare inalterata la colonna totali?perchè la macro la pulisce e li ho delle formule, ho provato a proteggerla ma poi la macro si blocca

[Flash30005]

Ok per Package in effetti io ero rimasto al messaggio precedente

Un unica cosa la colonna OTHERS è possibile farle prendere un valore di media tra: SPECIAL, LEISURE, WEB MERCHANT

dove c'era Leisure invece di Package quindi puoi modificare da solo la macro in questa maniera
nella macro precedente ci sono due righe (una per macro)
In RiepilogoRN troverai questa riga:

Codice: Seleziona tutto

            If Testata2 = "SPECIAL" Or Testata2 = "LEISURE" Or Testata2 = "WEB MERCHANT" Then Testata2 = "OTHERS"

che dovrai sostituire con

Codice: Seleziona tutto

            If Testata2 = "SPECIAL" Or Testata2 = "PACKAGE" Or Testata2 = "WEB MERCHANT" Then Testata2 = "OTHERS"


così anche nella macro RiepilogoADR:
prima:

Codice: Seleziona tutto

    If Testata4 = "SPECIAL" Or Testata4 = "LEISURE" Or Testata4 = "WEB MERCHANT" Then Testata4 = "OTHERS"


dopo modifica:

Codice: Seleziona tutto

 If Testata4 = "SPECIAL" Or Testata4 = "PACKAGE" Or Testata4 = "WEB MERCHANT" Then Testata4 = "OTHERS"

In pratica devi sostituire "LEISURE" con "PACKAGE" in queste due righe del programma.

Per il problema della cancellazione delle formule devi modificare in questa maniera la macro "CancellaVal":

Codice: Seleziona tutto

Sub CancellaVal()
    Worksheets("Sheet1").Select
    Range("B3:U33").ClearContents
    Range("A1").Select
End Sub

Ho visto nel file che hai spedito alcuni moduli inutili quindi se tutto questo codice è stato messo nel modulo1 puoi cancellare gli altri moduli (sulla finestra di sinistra, Gestione Progetti, selezioni il modulo e con tasto destro del mouse selezioni rimuovi moduloX, al messaggio di salvataggio rispondi NO)

Fai sapere se ok
Ciao

[Jack09]

Grazie Flash funziona perfettamente!!!!!!!!!!!!!!!!!