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.
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
che dire ??