Condividi:        

Filtro/copia, dati 2 valori da altro file

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: Filtro/copia, dati 2 valori da altro file

Postdi raimea » 16/09/12 20:25

confermo.... :oops:
infatti usando una macro di un altro file, che faceva un solo prelievo
l'ho applicata qui .

si' , sono 7 prelivi di 7 dati diversi dallo stesso file e stesso foglio.
all'inizio ho tentato di fare tutto in un unico "colpo" , ma ko non ci sono riuscito. :oops:
quando risolvevo una cosa si inchiodava su un altra....... x vari tentativi.

mi sono adeguato a questo, ripetendo 7 volte la stessa cosa e cambiando solo i referimenti di dove
copiare dove incollare.
ciao

questa la macro finale , con il codice che mi hai suggerito sopra:
Codice: Seleziona tutto
Sub prel1()

Inizio = Timer
UserForm2.Show vbModeless
DoEvents

ActiveSheet.Unprotect

    Range("B4:B103").Select ' tolgo i commenti
    Selection.ClearComments
   
    Range("FA4:Fe103").Select ' cancello dati precedenti
    Selection.ClearContents
    Range("b4:c103").Select   ' cancello dati precedenti
    Selection.ClearContents

Dim masopen As Boolean
ActiveSheet.Unprotect
Application.ScreenUpdating = False

'----------- primo prelievo le date-----------------

ActiveSheet.Unprotect
masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'------prelevo solo le celle con date e non quelle vuote-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare

Rini = ws2.Range("du27").Value  ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

If Not IsNumeric(Ws1.Range("c" & RR1).Value) And Ws1.Range("c" & RR1).Value <> "" Then
ws2.Range("c" & Inic).Value = Ws1.Range("c" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("c4").Select  ' la cella ws2 dove incollare i dati

'----------- secondo prelievo le squadre-----------------

ActiveSheet.Unprotect
masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'---prelevo solo le squadre in celle piene e non quelle vuote-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare

Rini = ws2.Range("du27").Value ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

If Not IsNumeric(Ws1.Range("G" & RR1).Value) And Ws1.Range("G" & RR1).Value <> "" Then
ws2.Range("B" & Inic).Value = Ws1.Range("G" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("B4").Select  ' la cella ws2 dove incollare i dati

'----------- terzo prelievo le quote-----------------

ActiveSheet.Unprotect
masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'filtra---prelevo solo le quote in file gol e non le celle vuote-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare

Rini = ws2.Range("du27").Value ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

If IsNumeric(Ws1.Range("I" & RR1).Value) And Ws1.Range("I" & RR1).Value <> "" Then
ws2.Range("D" & Inic).Value = Ws1.Range("I" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("d4").Select  ' la cella ws2 dove incollare i dati

'----------- quarto prelv nazioni-----------------

ActiveSheet.Unprotect

Dim IsNotNumber As Boolean

masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'filtra---prelevo solo celle piene-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare
Rini = ws2.Range("du27").Value ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

'If IsNumeric(Ws1.Range("F" & RR1).Value) And Ws1.Range("F" & RR1).Value <> "" Then
If Not IsNumeric(Ws1.Range("F" & RR1).Value) And Ws1.Range("F" & RR1).Value <> "" Then
ws2.Range("FA" & Inic).Value = Ws1.Range("F" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("FA4").Select  ' la cella ws2 dove incollare i dati

'----------- quinto prelievo gli orari-----------------

ActiveSheet.Unprotect
masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'filtra---prelevo solo le quote in gol e no le celle vuote-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare
Rini = ws2.Range("du27").Value ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

If IsNumeric(Ws1.Range("E" & RR1).Value) And Ws1.Range("E" & RR1).Value <> "" Then
ws2.Range("FB" & Inic).Value = Ws1.Range("E" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("FB4").Select  ' la cella ws2 dove incollare i dati

'----------- sesto prelev risultato finale-----------------
ActiveSheet.Unprotect
masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'filtra---prelevo solo le quote in gol e no le celle vuote-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare
Rini = ws2.Range("du27").Value ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

If Not IsNumeric(Ws1.Range("o" & RR1).Value) And Ws1.Range("o" & RR1).Value <> "" Then
ws2.Range("FC" & Inic).Value = Ws1.Range("o" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("FC4").Select  ' la cella ws2 dove incollare i dati

'----------- settimo prelev risultato finale V.P-----------------
ActiveSheet.Unprotect
masopen = ckf("gol.xls")
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile
Worksheets("1-gol-Fogl.Base").Activate   ' <<il foglio dal quale dove preleva

'filtra---prelevo solo le quote in gol e no le celle vuote-----
Application.Calculation = xlManual

Set Ws1 = Worksheets("1-gol-Fogl.Base")
Set ws2 = ThisWorkbook.Sheets("masaniello 1")

Inic = 4              ' la riga di ws2 dove iniziare ad incollare i dati
'For RR1 = 9 To 308    ' il range ws1 di gol dove operare
Rini = ws2.Range("du27").Value ' in du27 legge da quale riga cominciare a prelevare da file gol
For RR1 = Rini To 308

If Not IsNumeric(Ws1.Range("M" & RR1).Value) And Ws1.Range("M" & RR1).Value <> "" Then
ws2.Range("FE" & Inic).Value = Ws1.Range("M" & RR1).Value
Inic = Inic + 1
End If
Next RR1
Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Sheets("masaniello 1").Select
Range("FE4").Select  ' la cella ws2 dove incollare i dati

'-------metto la nazione orario ecc.. nel commento celle B-----------------------------

myArea = "B4:B103" '<< La tua area

For Each cella In Range(myArea)
    With cella
        .ClearComments
       
        If cella.Value <> "" Then     'mette il nome solo nelle celle piene
            .Select
            .AddComment
            .Comment.Visible = False
            .Comment.Text Text:="nazione:" & Chr(10) & Cells(cella.Row, "FA").Value _
               & " h " & Cells(cella.Row, "fb").Value _
                 & Chr(10) & " Ris.  " & Cells(cella.Row, "fc").Value '<<< chr10 indica andare a copa nella cella del commento
           
        End If
    End With
Next cella
   
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   
     Range("e1").Select
     
     Application.ScreenUpdating = True
   
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWindow.DisplayGridlines = False
'--------------------------------------------------------------------------------------

ActiveWindow.ScrollColumn = 1
Application.ScreenUpdating = True

ActiveWindow.DisplayGridlines = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFormattingRows:=True

'-----------------------------
Call graf1
Call giu1

Unload UserForm2
fine = Timer
MsgBox ("Tempo impiegato " & Int((fine - Inizio) / 60) & " min " & (fine - Inizio) Mod 60 & " Sec")


End Sub
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1410
Iscritto il: 11/02/10 07:33
Località: lago

Sponsor
 

Re: Filtro/copia, dati 2 valori da altro file

Postdi Flash30005 » 16/09/12 21:36

Per esempio una macro così (ho modificato la macro inserendo tutto in un solo ciclo For next), provala!

Codice: Seleziona tutto
Sub prel1()

Inizio = Timer
UserForm2.Show vbModeless
DoEvents

ActiveSheet.Unprotect

    Range("B4:B103").Select ' tolgo i commenti
    Selection.ClearComments
   
    Range("FA4:Fe103").Select ' cancello dati precedenti
    Selection.ClearContents
    Range("b4:c103").Select   ' cancello dati precedenti
    Selection.ClearContents

Dim masopen As Boolean
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Set Ws2 = ThisWorkbook.Sheets("masaniello 1")
nomefile = ThisWorkbook.Name
Nomefoglio = "Masaniello 1"

masopen = ckf("gol.xls") '<<< dichiarazione da inserire, fai F8 e vedi, True=file gia' aperto
percorso = Application.ActiveWorkbook.Path
Application.EnableEvents = False  '<<<<<<<< per non far partire il lampeggio in fgl1
Nfile = "\" & "gol.xls"
If masopen = False Then Application.Workbooks.Open percorso & Nfile

'----------- primo prelievo le date-----------------

Set Ws1 = Worksheets("1-gol-Fogl.Base")

Ws1.Activate   ' <<il foglio dal quale dove preleva
ActiveSheet.Unprotect
'------prelevo solo le celle con date e non quelle vuote-----
Application.Calculation = xlManual

InicC = 4               ' la riga di ws2 dove iniziare ad incollare i dati
InicB = 4               ' la riga di ws2 dove iniziare ad incollare i dati
InicD = 4               ' la riga di ws2 dove iniziare ad incollare i dati
InicFA = 4              ' la riga di ws2 dove iniziare ad incollare i dati
InicFB = 4              ' la riga di ws2 dove iniziare ad incollare i dati
InicFC = 4              ' la riga di ws2 dove iniziare ad incollare i dati
InicFE = 4              ' la riga di ws2 dove iniziare ad incollare i dati
Rini = Ws2.Range("Du23").Value   ' il range ws1 di gol dove operare
For RR1 = Rini To 308

If Not IsNumeric(Ws1.Range("c" & RR1).Value) And Ws1.Range("c" & RR1).Value <> "" Then
Ws2.Range("c" & InicC).Value = Ws1.Range("c" & RR1).Value
InicC = InicC + 1
End If

If Not IsNumeric(Ws1.Range("G" & RR1).Value) And Ws1.Range("G" & RR1).Value <> "" Then
Ws2.Range("B" & InicB).Value = Ws1.Range("G" & RR1).Value
InicB = InicB + 1
End If

If IsNumeric(Ws1.Range("I" & RR1).Value) And Ws1.Range("I" & RR1).Value <> "" Then
Ws2.Range("D" & InicD).Value = Ws1.Range("I" & RR1).Value
InicD = InicD + 1
End If

If Not IsNumeric(Ws1.Range("F" & RR1).Value) And Ws1.Range("F" & RR1).Value <> "" Then
Ws2.Range("FA" & InicFA).Value = Ws1.Range("F" & RR1).Value
InicFA = InicFA + 1
End If

If IsNumeric(Ws1.Range("E" & RR1).Value) And Ws1.Range("E" & RR1).Value <> "" Then
Ws2.Range("FB" & InicFB).Value = Ws1.Range("E" & RR1).Value
InicFB = InicFB + 1
End If

If Not IsNumeric(Ws1.Range("o" & RR1).Value) And Ws1.Range("o" & RR1).Value <> "" Then
Ws2.Range("FC" & InicFC).Value = Ws1.Range("o" & RR1).Value
InicFC = InicFC + 1
End If

If Not IsNumeric(Ws1.Range("M" & RR1).Value) And Ws1.Range("M" & RR1).Value <> "" Then
Ws2.Range("FE" & InicFE).Value = Ws1.Range("M" & RR1).Value
InicFE = InicFE + 1
End If

Next RR1

Application.Calculation = xlCalculationAutomatic
'------------------------

Application.EnableEvents = True    '< per non far partire il lampeggio in fgl1

Application.CutCopyMode = False  '<<< toglie avviso di molti dati
If masopen = False Then ActiveWorkbook.Close savechanges:=False
Workbooks(nomefile).Activate
Sheets(Nomefoglio).Select
Range("FE4").Select  ' la cella ws2 dove incollare i dati

'-------metto la nazione orario ecc.. nel commento celle B-----------------------------

myArea = "B4:B103" '<< La tua area

For Each cella In Range(myArea)
    With cella
        .ClearComments
       
        If cella.Value <> "" Then     'mette il nome solo nelle celle piene
            .Select
            .AddComment
            .Comment.Visible = False
            .Comment.Text Text:="nazione:" & Chr(10) & Cells(cella.Row, "FA").Value _
               & " h " & Cells(cella.Row, "fb").Value _
                 & Chr(10) & " Ris.  " & Cells(cella.Row, "fc").Value '<<< chr10 indica andare a copa nella cella del commento
           
        End If
    End With
Next cella
   
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   
     Range("e1").Select
     
     Application.ScreenUpdating = True
   
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveWindow.DisplayGridlines = False
'--------------------------------------------------------------------------------------

ActiveWindow.ScrollColumn = 1
Application.ScreenUpdating = True

ActiveWindow.DisplayGridlines = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFormattingRows:=True

'-----------------------------
Call graf1
Call giu1

Unload UserForm2
fine = Timer
MsgBox ("Tempo impiegato " & Int((fine - Inizio) / 60) & " min " & (fine - Inizio) Mod 60 & " Sec")


End Sub


Ciao

P.s. Noterai che impiega un tempo notevolmente inferiore
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: Filtro/copia, dati 2 valori da altro file

Postdi raimea » 17/09/12 05:56

:o che dire ??
GRAZIE.
e' tutto ok,e veloccissima.
di.nuovo grazie
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1410
Iscritto il: 11/02/10 07:33
Località: lago

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "Filtro/copia, dati 2 valori da altro file":


Chi c’è in linea

Visitano il forum: Nessuno e 160 ospiti