vettori e cercavert

Hai un problema con Excel?

Nuova discussione

vettori e cerca.vert
di rplacanica data: 12/11/2012 19:49:42
Buona sera a tutti,

vorrei utilizzare il cerca.vert (vLookup in vba) creando un vettore precompilato nel vba, cioè senza determinare un range sul foglio excel per poi popolare tutta una colonna come da codice sotto
è' possibile o mi devo creare un range "temporaneo" sul foglio di lavoro per poi cancellarlo?
INTERCOMPANY = Array("company 1", "soc x", "soc c", "soc q", "soc...", "soc z") Range("W2:W" & LAST_ROW).FormulaR1C1 = "=IF(VLOOKUP(RC[-8],INTERCOMPANY,1,FALSE) ,""intercompany"",""Terzi"")"
di Vecchio Frac data: 12/11/2012 20:19:44
Questo era uno dei punti che, appena potevo mettermi con calma, volevo suggerirti di ottimizzare.
Anzichè inserire formule nel foglio, perchè non fai calcolare da VBA il valore da inserire nella cella desiderata?
Questa soluzione evita di infarcire il foglio di formule che appesantiscono e rallentano.
Sempre se, naturalmente, non hai bisogno assolutamente di costellare il foglio di formule perchè i valori cambiano e non vuoi lanciare la macro tutte le volte che varia un dato.

Comunque per risolvere questo problema dovresti prima risolvere il VLookup facendoti restituire l'elemento dell'Array corrispondente al valore cercato e poi inserendo il valore di ritorno nella formula con l'opportuna concatenazione di stringhe di cui all'altro thread.
di Rplacanica (utente non iscritto) data: 12/11/2012 23:02:10
Come avrai visto, calcolo tutto e poi seleziono il range di interesse e copio i valori con
C.value=c.value
Non mi occorre tenere le formule visto che il master è statico

Per la soluzione al mio problema, riesci a spiegarti meglio?

di Vecchio Frac data: 13/11/2012 09:39:18
cit. " Non mi occorre tenere le formule visto che il master è statico "
---> Ancora meglio, allora la soluzione che ho proposto nell'altro thread è sicuramente valida e la depureremo degli errori se potremo lavorare su un file di dati (fittizi ma) concreto.
Risolvere il VLookup vuol dire che devi separare le due istruzioni.
Prima calcoli VLookup e ottieni un risultato.
Poi recuperi l'elemento dell'Array che corrisponde al risultato cercato.
Infine sbatti questo elemento dentro la formula ^_^

Oppure calcoli la formula direttamente e immetti il valore nella cella (qualcosa come quello che segue, salvo errori dovuti al fatto che non ho una base dati su cui provare):

INTERCOMPANY = Array("company 1", "soc x", "soc c", "soc q", "soc...", "soc z")

'la colonna è la W. Notare il metodo simpatico per scovare un elemento all'interno di un Array
Range(Cells(i, 23), Cells(LAST_ROW, 23)) = IIf( instr(1, vbnullchar & join(INTERCOMPANY, vbnullchar) & vbnullchar, vbnullchar & Cells(i, 15) & vbnullchar)>0, "intercompany", "Terzi" )

di Rplacanca (utente non iscritto) data: 14/11/2012 23:45:50
Ciao, ho inserito il codice e ho provato a far girare il tutto... Non girava bene.
Il risultato era sempre TERZI anche nel caso incui ci fosse un cliente intercompany.
Ho dovuto martellare con un ciclo for next dalla riga 2 alla riga ultimarow

Probabilmente può essere fatto meglio.
Conto di mettere a disposizione il file per una miglior codifica e testing, domani

di rplacanica data: 15/11/2012 10:40:44
come promesso ho caricato file e qui sotto il codice.
mi piacerebbe poter dare la possibilità all'utente di estrarre più e/c, semplicemente impostando un "Vuoi importare un altro file?" Si/No
mi è chiaro il ciclo if...else... con il goto per riprendere il loop fino ad uscita
ma non saprei come fare riconoscere la Risposta Si/no al msgbox.

i singoli import poi li inserirei nel medesimo database, in modo da poter generare un e/c di gruppo, da cui poi fare il consolidamento
(replicherei la medesima struttura sugli e/c fornitori)

Grazie in anticipo a chi mi potrà aiutare, anche a razionalizzare anche il codice
La parte relativa alle pivot l'ho fatta quardando il testo di Giaccaglini e inserendo alcune parti "registrate,tagliate e riadattate"
Se mi aiutate a correggere e razionalizzare anche questo :) mi aiutate a crescere in un mondo che mi sta appassionando sempre di più!

Sub IMPORT_SCADENZARI()
'
' IMPORT SCADENZARI Macro
' Creata da Roberto Placanica 15/10/2012
' con fondamentali contributi di Vecchio Frac di excelvba.altervista'
'
Dim varFileName
Dim LAST_ROW As Integer
Dim LAST_ROW2 As Integer
Dim COMP As String
Dim UltimaRigaFiltro As Integer
Dim DATESCAD As Variant
Dim INTERCOMPANY As Variant
Dim i As Integer
Dim Path As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Path = "H:"
COMP = Application.InputBox("Società", "inserire nome società", "SIFAVITOR")
        If COMP = CStr(False) Then
        Exit Sub
        End If
DATESCAD = Application.InputBox("Considero scadute le fatture anteriori al", "Inserire data scadenza", "31/12", , , , , 6)
        If DATESCAD = CStr(False) Then
        Exit Sub
        End If
DATESCAD = CDate(DATESCAD)


    Workbooks.Add
    
    varFileName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
        
    If TypeName(varFileName) = "String" Then
        
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & varFileName, Destination:=Range("A1"))
            .Name = "Import da AS400"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 61
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
            .TextFileFixedColumnWidths = Array(11, 11, 7, 7, 7, 7, 16, 15, 17, 2, 4, 11, 17)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    
    Sheets.Add After:=Sheets(Sheets.Count)
        
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & varFileName, Destination:=Range("A1"))
            .Name = "Import da AS400"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 60
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1)
            .TextFileFixedColumnWidths = Array(132)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    End If

'dal foglio2 ricavo i nomi dei clienti, poi elimino il folgio
    
    Sheets("Foglio2").Select
    Columns("A:A").Select
    Selection.Copy
    Sheets("Foglio1").Select
    Columns("N:N").Select
    ActiveSheet.Paste
    Sheets("Foglio2").Select
    ActiveWindow.SelectedSheets.Delete
    
'trovo l 'ultima cella attiva e memorizzo la riga
 LAST_ROW = ActiveCell.SpecialCells(xlLastCell).Row

' inserisco la colonna con il mome della società
    
    Columns("A:A").Insert Shift:=xlToRight
    Range("A1") = "Società"
    Range("a2:A" & LAST_ROW).Value = COMP
    

    'inserisco le intestazioni dei campi - versione di Vecchio Frac
        For i = 2 To 23
           Cells(1, i) = Choose(i, "Società", "Codice Cliente", "Fattura", "Data Ft", "Doc N.", "Reg. N.", _
            "TP", "Contanti", "Effetti", "Altro", "P", "Div", "Cambio", "Importo in Val", "Cliente", _
            "Scadenza", "Anno", "Mese", "Data_doc", "Estrazione", "Settimana", "Scaduto", "INTERCOMPANY")

      Next
    
'   inserisco le intestazioni e le formule dei campi - mia versione
    With Range("P2:P" & LAST_ROW)
        .FormulaR1C1 = "=IF(LEFT(RC[-14],8)=""Scadenza"",RC[-13],R[-1]C[])"
        .NumberFormat = "dd/mm/yy"
    End With
        Range("Q2:q" & LAST_ROW) = "=IFERROR(YEAR(RC[-1]),"""")"
        Range("R2:r" & LAST_ROW) = "=IFERROR(MONTH(RC[-2]),"""")"
    With Range("S2:s" & LAST_ROW)
        .FormulaR1C1 = "=+IF(RC[-15]<>0,RC[-15],"""")"
        .NumberFormat = "dd/mm/yy"
    End With
        Range("T2:t" & LAST_ROW) = "=TEXT(IFERROR(AND(VALUE(RC[-14]),VALUE(RC[-18])),""FALSO""),0)"
        Range("U2:u" & LAST_ROW) = "=WEEKNUM(RC[-5],1)"
        Range("v2:v" & LAST_ROW).FormulaR1C1 = "=+IF(RC[-6]<=" & CLng(DATESCAD) & ",""scaduto"",""a scadere"")"

INTERCOMPANY = Array("DERIVADOS QUIMICOS S.A.U.", "INFA GmbH", "INFA S.A.", "INFA SA", "INFA GROUP S.P.A.", "SIFAVITOR SRL", "LABORATORIO CHIMICO INTERNAZIONALE")

'di Vecchio Frac: la colonna è la W. Notare il metodo simpatico per scovare un elemento all'interno di un Array
For i = 2 To LAST_ROW
Range(Cells(i, 23), Cells(LAST_ROW, 23)) = IIf(InStr(1, vbNullChar & Join(INTERCOMPANY, vbNullChar) & vbNullChar, vbNullChar & Cells(i, 15) _
& vbNullChar) > 0, "intercompany", "Terzi")
Next
    
'copia e incolla i valori
   Range("P2:w" & LAST_ROW).Select
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   Application.CutCopyMode = False

'   elimino le celle inutili
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("A1:t" & LAST_ROW).AutoFilter Field:=20, Criteria1:="FALSO"
    UltimaRigaFiltro = Range("A1").End(xlDown).Row
    Rows("2:" & UltimaRigaFiltro).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.ShowAllData
    
    LAST_ROW2 = [COUNTA(A:A)] 'idea del grande Vecchio Frac
    Range("l2:l" & LAST_ROW2).Replace What:="", Replacement:="EURO"
    
'Creo Le pivot

    pivot
    
    
Application.ScreenUpdating = True

'per salvataggio automatico togliere apice

'ActiveWorkbook.SaveAs Filename:=Path & COMP & " PARTITE SCADUTE", FileFormat:=xlOpenXMLWorkbook

End Sub
    
Sub pivot()

Dim UltimaRiga    As Long
Dim UltimaColonna As Long
Dim DataMax       As Long
Dim DataMin       As Long
Dim groupRange    As Range

Dim wbOut           As Excel.Workbook
Dim wshOutData      As Excel.Worksheet
Dim wshOutPivot     As Excel.Worksheet

Dim objPCch As Excel.PivotCache
Dim objPTbl As Excel.PivotTable



MsgBox ("creo la prima pivot")


Application.ScreenUpdating = False

    Set wbOut = Application.ActiveWorkbook
    Set wshOutData = Application.ActiveSheet
    Set wshOutPivot = wbOut.Worksheets.Add     'aggiunge un nuovo foglio per la pivot
    
    UltimaRiga = wshOutData.Range("A1").End(xlDown).Row
    UltimaColonna = wshOutData.Range("A1").End(xlToRight).Column
            
' cerco la data massima della scadenza
    DataMax = Application.WorksheetFunction.Max(wshOutData.Range("p:p"))
' cerco la data minima della scadenza
    DataMin = Application.WorksheetFunction.Min(wshOutData.Range("P:p"))
    
    Set objPCch = wbOut.PivotCaches. _
        Add(xlDatabase, SourceData:=wshOutData.Range(wshOutData.Cells(1, 1), wshOutData.Cells(UltimaRiga, UltimaColonna)))
        
    Set objPTbl = objPCch.CreatePivotTable _
        (wshOutPivot.Range("A1"), TableName:="CLIENTE_SCADENZE", DefaultVersion:=xlPivotTableVersion10)

      
' aggiungo i campi relativi ai dati

    With objPTbl.PivotFields("Importo in Val")
        .Orientation = xlDataField
        .Caption = "Tot. in Val"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Contanti")
        .Orientation = xlDataField
        .Caption = "Contanti €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Altro")
        .Orientation = xlDataField
        .Caption = "Altro €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
 objPTbl.DataPivotField.Orientation = xlColumnField
 
'formatta il campo data nel foglio 1
    
    wshOutData.Columns("p:p").NumberFormat = _
    "dd/mm/yy;@"
    objPTbl.PivotCache.Refresh


   With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
        .Caption = "Scad"
    End With

'raggruppa per Trimestre e Mese il campo Data

    Set groupRange = objPTbl.PivotFields("SCAD") _
                            .DataRange
        
            groupRange.Cells(1).Group _
            Start:=DataMin, End:=DataMax, _
            Periods:=Array(False, False, False, _
            True, True, False, True)

       
 ' inserisco i campi riga
  objPTbl.AddFields RowFields:= _
        Array("Cliente", "Società", "Div", "scad")
 
 
'inserisco i campi pagina

    With objPTbl.PivotFields("Anni")
        .Orientation = xlPageField
        .Caption = "Anni"
    End With

    With objPTbl.PivotFields("INTERCOMPANY")
        .Orientation = xlPageField
        .Caption = "CONSO"
        .CurrentPage = "TERZI"
    End With
  
' evidenzio i totali
   ActiveSheet.PivotTables("CLIENTE_SCADENZE").PivotSelect _
        "Cliente[All;Total] Terzi", xlDataAndLabel, True
    With Selection
        .Font.Bold = True
        .Font.Size = 10
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
        

'nascondiamo i dettagli della pivot
    objPTbl.PivotSelect "'Cliente'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotSelect "'Società'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotCache.Refresh
'    wshOutData.Visible = True
    Cells.EntireColumn.AutoFit
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.DisplayAutomaticPageBreaks = False

'=====================================
'
' INSERISCO LA SECONDA PIVOT
'
'=====================================

MsgBox ("creo la seconda pivot")


Set wshOutPivot = wbOut.Worksheets.Add     'aggiunge un nuovo foglio per la pivot
Set objPTbl = objPCch.CreatePivotTable _
        (wshOutPivot.Range("A1"), TableName:="SCADENZE_CLIENTE", DefaultVersion:=xlPivotTableVersion10)

' aggiungo i campi relativi ai dati

    With objPTbl.PivotFields("Importo in Val")
        .Orientation = xlDataField
        .Caption = "Tot Valuta"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Contanti")
        .Orientation = xlDataField
        .Caption = "Contanti €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
 objPTbl.DataPivotField.Orientation = xlColumnField
 
 With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
 End With

'raggruppa per Trimestre - Mese - Giorno il campo Data
    
    Set groupRange = objPTbl.PivotFields("SCADENZA") _
                            .DataRange
        
            groupRange.Cells(1).Group _
            Start:=DataMin, End:=DataMax, _
            Periods:=Array(False, False, False, _
            True, True, False, True)

' inserisco i campi riga
    With objPTbl
        .AddFields RowFields:=Array("Mesi", "Cliente", "Fattura", "Data Ft", "scadenza")


    End With
    
    With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
        .Caption = "Data Scadenza"
        .NumberFormat = "gg/mm/aa"
    End With
 
 'inserisco i campi colonna
 With objPTbl.PivotFields("Div")
        .Orientation = xlColumnField
        .Caption = "Valuta"
        .Position = 1
 End With

'inserisco i campi pagina

    With objPTbl.PivotFields("Anni")
        .Orientation = xlPageField
        .Caption = "Anni"
    End With

    With objPTbl.PivotFields("INTERCOMPANY")
        .Orientation = xlPageField
        .Caption = "CONSO"
        .CurrentPage = "TERZI"
    End With
    
    With objPTbl.PivotFields("SCADUTO")
        .Orientation = xlPageField
        .CurrentPage = "scaduto"
    End With
    
     ' questa parte mi sembra un pochino ridondante, come potrei sistemarla?
     
    objPTbl.PivotFields("Data Scadenza"). _
        Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
        False, False)
    objPTbl.PivotFields("Data Ft").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Fattura").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Cliente").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Mesi").Subtotals = _
        Array(True, False, False, False, False, False, False, False, False, False, False, False)

' evidenzio i totali
    ActiveSheet.PivotTables("SCADENZE_CLIENTE").PivotSelect "Mesi[All;Total] Terzi" _
        , xlDataAndLabel, True
    With Selection
        .Font.Bold = True
        .Font.Size = 10
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
        

'nascondiamo i dettagli della pivot
    objPTbl.PivotSelect "'mesi'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotSelect "'Cliente'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotCache.Refresh
    wshOutData.Visible = True
    Cells.EntireColumn.AutoFit
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.DisplayAutomaticPageBreaks = False
    Application.ScreenUpdating = True

MsgBox ("Estrazione terminata")



End Sub

di Vecchio Frac data: 15/11/2012 20:16:01
cit. "Ho dovuto martellare con un ciclo for next dalla riga 2 alla riga ultimarow "
---> naturalmente con un pezzo di codice estrapolato dal contesto non si potevano fare miracoli ^_^
Hai fatto bene a postare il codice, adesso possiamo ragionare sull'insieme.
di Rplacanica (utente non iscritto) data: 15/11/2012 23:17:22
Perfetto! Aspetto con impazienza la correzione del compito....
di Vecchio Frac data: 17/11/2012 09:32:52
Rispondo solo per vedere il messaggio in top alla lista e non dimenticarmene ^_^
Purtroppo non ho avuto ancora modo di applicarmi, ma non lo ignoro.
di Rplacanica (utente non iscritto) data: 17/11/2012 23:30:15
Figurati...
Nel mio caso sarebbe un abbellimento, che comunque aiuta a crescere.

Mi interesserebbe invece il consiglio su come operare per rendere più interattiva l'importazione.

Ma stai tranquillo, fino a giovedì non potrò operare perchè impegnato in terra di Spagna...
di Vecchio Frac data: 18/11/2012 09:14:48
Uau... buona vacanza (se è per vacanza) e buon lavoro (se è per lavoro) ^_^
di Vecchio Frac data: 18/11/2012 12:39:29
Ho problemi con il formato del file .txt; non riesco a fargli incolonnare bene i dati.
di Rplacanica (utente non iscritto) data: 18/11/2012 14:17:07
Lavoro...

Le colonne che mi occorrono sono separate come da codice...
Che problemi incontri?
di Vecchio Frac data: 18/11/2012 20:50:53
Supponendo che il file da dare in pasto alla QueryTable sia quello che hai allegato, i dati mi vengono completamente sfarfugliati nel foglio e devo capire il perchè, insomma non ottengo dei dati incolonnati per voce.
Allego una piccola immagine, spero che non risulti sgranata.
di Rplacanica (utente non iscritto) data: 18/11/2012 22:05:24
È corretto,
Fai girare la macro passo passo e vedrai come si sistema.
Per evitare problemi, mporto due volte il file, il secondo é di una unica colonna e incollo il tutto una riga più in basso. In questo modo il cliente si posiziona allineato alla riga della partita.

Le operazioni preliminari al filtro, occorrono per determinare cosa tenere e cosa segare.

La cosa per cui ti chiedo aiuto è la possibilitá di reiterare il job quante volte si vuole, richiedendo il nome della societá e appendendo il nuovo estratto pulito sotto quello precedente.

In pratica la capogruppo che analizza i dati, può importare tutti i crediti e analizzarli in maniera raggruppata....
Questo aiuterebbe anche per il consolidato per vedere se tutte le societá indicano nei confronti delle societá del gruppo ammontaredi debiti e crediti reciprocamente bilancianti.

Spero di essere stato comprensibile...

di Vecchio Frac data: 19/11/2012 10:23:07
Comprensibile lo è, e anche il meccanismo del codice che crea una forse inutile copia della QueryTable quando basterebbe una semplice copia delle colonne interessate, ma vabbè si tratta di fare la punta alle matite :)
Dicevi che non ti funzionava il metodo con Join per scovare un elemento all'interno di un Array (ma mi sembra strano, la funzioncina funziona perfettamente e non dà problemi, è evidente che applicata al contesto c'è qualcosa che mi sfugge).
Sulla ripetizione dell'intero progetto, probabilmente ci basta considerare questa sub una routine di servizio, che deve essere richiamata all'interno di un While ... Wend (o Do ... Loop, de gustibus) principale, passandole opportunamente il valore di COMP (che è la società in esame).
Quindi anche la firma di IMPORT_SCADENZARI cambia:
Sub IMPORT_SCADENZARI(COMP As String)
...e naturalmente nel suo codice togli la richiesta di COMP mediante InputBox (e anche il Dim COMP che crea altrimenti una nuova variabile locale in conflitto con quella passata in argomento).
Sull'incolonnare l'estratto sotto al precedente, occorrerà evitare di creare qui un nuovo Workbook (va fatto nella sub principale IMPORT) e probabilmente la QueryTables.Add dovrà tenere conto del nuovo range di Destination.
Is this correct? :)

Option Explicit

Sub Import()
Dim COMP As String

    While Trim(COMP) = ""
        COMP = Application.InputBox("Società", "inserire nome società", "SIFAVITOR")
        If Trim(COMP) = (False) Then MsgBox "Fine procedura": Exit Sub
    Wend
    
    Workbooks.Add
    Call IMPORT_SCADENZARI(COMP)
End Sub

di rplacanica (utente non iscritto) data: 19/11/2012 20:10:18
il re importare una seconda volta mi è sembrato più veloce e semplice che star li a pensare cosa e come ricavare qualcosa da quello che già ho; alla fine della nuova import mi tengo solo una colonna, quella che mi dà l'esatta ragione sociale del cliente.
Per l'array, non è che non funzionasse, ma per come era scritta (credo, visto che non ho capito molto... ) mi metteva sempre "terzi".
Ho duvuto massaggiare un po inserendo un "for i....next" che credo che nella costruzione generale faccia un po' acqua ma fa il suo porco lavoro.

appena riesco mi scopiazzo il codice e vedo se gira tutto come gradirei.
Per ora ti ringrazio moltissimo!

ps. il codice relativo alle pivot va bene o no...
di Vecchio Frac data: 19/11/2012 21:54:08
Mi dispiace ma non riesco :(

cit. "È corretto, Fai girare la macro passo passo e vedrai come si sistema. "
---> A me non si "sistema" come penso dovrebbe.
Si spezza il testo su più colonne, i dati non sono incolonnati, in qualche punto compare un = che Excel interpreta come formula e quindi si arrabbia.
Se mi fornisci (quando torni) il risultato finale, come dovrebbe essere, forse posso capire di più.
di rplacanica (utente non iscritto) data: 19/11/2012 22:58:35
ok
ora sono senza batteria e ho dimenticato l'adattatore hispanico --> schuko...
mannaggia! quando faremo un presa unica europea?!
vabbè ci son altri problemi più seri...
di rplacanica (utente non iscritto) data: 20/11/2012 13:13:22
ho allegato il file finale...
di Vecchio Frac data: 20/11/2012 14:12:19
Grazie. Vedo.
E' quel benedetto "Foglio1" che non riesco a ottenere lanciando la tua macro; forse che QueryTable agisce in modo diverso da Excel 2003 e il tuo Excel più nuovo? mistero. Dovrò aprire la mia famosa macchina virtuale e vedere cosa mi combina lì.
di rplacanica (utente non iscritto) data: 20/11/2012 15:43:32
si, ho 2007 :)
scusa la breve nota ma scrivo con Black berry
di rplacanica (utente non iscritto) data: 22/11/2012 11:30:00
Ciao Vecchio Frac,
il loop non gira come vorrei.
spiego meglio l'idea:
lancio la macro, inserisco la società ecc... e creo il foglio 1 Grezzo (dato dalla import su foglio1 e copia incolla della seconda import) + colonna AA con società "comp"
a questo punto mi chiede se voglio far girare una seconda import:
sì= riprende il loop
a questo punto devo fare cercare l'ultima riga "UR"e assegnare alla Range("a"&UR+1) la posizione per il nuovo import
il secondo foglio viene sempre, reimportato, copiato incollato ed eliminato e si chiama sempre "Foglio2" (mmm ora che ci penso, forse potrei evitarlo
facendogli concatenare tutte le celle precedenti....)

no= richiama le operazioni per la pulizia dei dati e crea le pivot

:) ci sto lavorando ma non "looppa"... forse all'interno della sub Import scadenzari dovrei richiamare ancora la import di servizio?

come posso fare il tutto con il msg box
"vuoi importare ancora?
Si/no

Grazie in anticipo!

di rplacanica (utente non iscritto) data: 22/11/2012 20:11:35
Dopo varie prove ho ottenuto quel che volevo, e questo di per se stesso è un successo...
pertanto metterei la spunta su risolto.
mi piacerebbe però che "a tempo perso" i nostri guru dessero una ochiata ai codici per aiutarmi a renderli anche esteticamente migliori.

Sub Import()
'
'
Dim comp As String
Dim varFileName
Dim R As Integer
Dim risp As Variant
Dim Path As String
Dim LAST_ROW As Integer
Dim LAST_ROWC As Integer 'riga del foglio clienti
Dim LAST_ROW2 As Integer
Dim UltimaRigaFiltro As Integer
Dim DATESCAD As Variant
Dim INTERCOMPANY As Variant
Dim i As Integer
Dim importaz As Range
'
'
'
'
Path = "H:"
'
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
        
Application.SheetsInNewWorkbook = 1     'quando creo una nuova cartella questa contine solo un foglio
Workbooks.Add

Do
    comp = Application.InputBox("Società", "inserire nome società", "SIFAVITOR")
    R = ActiveCell.SpecialCells(xlLastCell).Row
    If R = 1 Then
    R = 1
    Else: R = R + 1
    End If
        
    varFileName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
        
    If TypeName(varFileName) = "String" Then
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & varFileName, Destination:=Range("A" & R))
            .Name = "Import da AS400"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 61
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 2, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
            .TextFileFixedColumnWidths = Array(11, 11, 7, 7, 7, 7, 16, 15, 17, 2, 4, 11, 17)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
' inserisco la colonna con il mome della società nella colonna N
        Range("n1") = "Società"
        LAST_ROW = ActiveCell.SpecialCells(xlLastCell).Row  'trovo l 'ultima cella attiva e memorizzo la riga
        Range(Cells(R, 14), Cells(LAST_ROW, 14)).Value = comp 'compilo in modo variabile a seconda dell'import
        
        
        
        
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Foglio2"


        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & varFileName, Destination:=Range("A1"))
            .Name = "Importaz"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 60
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1)
            .TextFileFixedColumnWidths = Array(132)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    End If

'dal foglio2 ricavo i nomi dei clienti, poi elimino il foglio

    Sheets("Foglio2").Select
    Range("importaz").Select
    LAST_ROWC = Range("a1").SpecialCells(xlLastCell).Row
    Range(Cells(1, 1), Cells(LAST_ROWC, 1)).Select
    Selection.Copy
    Sheets("Foglio1").Select
    Range(Cells(R, 15), Cells(LAST_ROW, 15)).PasteSpecial
    Sheets("Foglio2").Delete
                        
'    Sheets("Foglio2").Select
'    ActiveWindow.SelectedSheets.Delete
                    
    
        
                    
    risp = MsgBox("Devo importare ancora?", vbYesNo)
Loop While risp = vbYes

' imposto la data dalla quale considerare scadute le fatture
        
        DATESCAD = Application.InputBox("Considero scadute le fatture anteriori al", "Inserire data scadenza", "31/12", , , , , 6)
                If DATESCAD = CStr(False) Then
                Exit Sub
                End If
        DATESCAD = CDate(DATESCAD)
            
        
        'inserisco le intestazioni dei campi - versione di Vecchio Frac
                For i = 2 To 23
                   Cells(1, i) = Choose(i, "Codice Cliente", "Fattura", "Data Ft", "Doc N.", "Reg. N.", _
                    "TP", "Contanti", "Effetti", "Altro", "P", "Div", "Cambio", "Importo in Val", "Società", "Cliente", _
                    "Scadenza", "Anno", "Mese", "Data_doc", "Estrazione", "Settimana", "Scaduto", "INTERCOMPANY")
        
              Next
            
        '   inserisco le intestazioni e le formule dei campi - mia versione
            With Range("P2:P" & LAST_ROW)
                .FormulaR1C1 = "=VALUE(IF(LEFT(RC[-15],8)=""Scadenza"",RC[-14],R[-1]C[]))"
                .NumberFormat = "dd/mm/yy"
            End With
                Range("Q2:q" & LAST_ROW) = "=IFERROR(YEAR(RC[-1]),"""")"
                Range("R2:r" & LAST_ROW) = "=IFERROR(MONTH(RC[-2]),"""")"
            With Range("S2:s" & LAST_ROW)
                .FormulaR1C1 = "=+IF(RC[-16]<>0,RC[-16],"""")"
                .NumberFormat = "dd/mm/yy"
            End With
                Range("T2:t" & LAST_ROW) = "=TEXT(IFERROR(AND(VALUE(RC[-13]),VALUE(RC[-17])),""FALSO""),0)"
                Range("U2:u" & LAST_ROW) = "=WEEKNUM(RC[-5],1)"
                Range("v2:v" & LAST_ROW).FormulaR1C1 = "=+IF(RC[-6]<=" & CLng(DATESCAD) & ",""scaduto"",""a scadere"")"
        
        INTERCOMPANY = Array("DERIVADOS QUIMICOS S.A.U.", "INFA GmbH", "INFA S.A.", "INFA SA", "INFA GROUP S.P.A.", "SIFAVITOR SRL", "LABORATORIO CHIMICO INTERNAZIONALE")
        
        'di Vecchio Frac: la colonna è la W. Notare il metodo simpatico per scovare un elemento all'interno di un Array
        'di rplacanica: ho trovato l'errore!!! anzichè Range(Cells(i, 23), Cells(i, 23)) c'era scritto Range(Cells(i, 23), Cells(LAST_CELL, 23)) e quindi compilava
        'tutto insieme !!!
        For i = 2 To LAST_ROW
        Range(Cells(i, 23), Cells(i, 23)) = IIf(InStr(1, vbNullChar & Join(INTERCOMPANY, vbNullChar) & vbNullChar, vbNullChar & Cells(i, 15) _
        & vbNullChar) > 0, "intercompany", "Terzi")
        Next
            
        'copia e incolla i valori
           Range("n2:w" & LAST_ROW).Select
           Selection.Copy
           Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           Application.CutCopyMode = False
        
        '   elimino le celle inutili
            Cells.Select
            Selection.AutoFilter
            ActiveSheet.Range("A1:w" & LAST_ROW).AutoFilter Field:=20, Criteria1:="FALSO"
            UltimaRigaFiltro = Range("t1").End(xlDown).Row
            Rows("2:" & UltimaRigaFiltro).Select
            Selection.Delete Shift:=xlUp
            ActiveSheet.ShowAllData
            
            LAST_ROW2 = [COUNTA(A:A)]
            Range("k2:k" & LAST_ROW2).Replace What:="", Replacement:="EURO"
            
        'Creo Le pivot
        
            PIVOT
            
            
        Application.ScreenUpdating = True
        
        'per salvataggio automatico togliere '
        
        'ActiveWorkbook.SaveAs Filename:=Path & COMP & " PARTITE SCADUTE", FileFormat:=xlOpenXMLWorkbook

End Sub
Sub PIVOT()

Dim UltimaRiga    As Long
Dim UltimaColonna As Long
Dim DataMax       As Long
Dim DataMin       As Long
Dim groupRange    As Range

Dim wbOut           As Excel.Workbook
Dim wshOutData      As Excel.Worksheet
Dim wshOutPivot     As Excel.Worksheet

Dim objPCch As Excel.PivotCache
Dim objPTbl As Excel.PivotTable



MsgBox ("creo la prima pivot")


Application.ScreenUpdating = False

    Set wbOut = Application.ActiveWorkbook
    Set wshOutData = Application.ActiveSheet
    Set wshOutPivot = wbOut.Worksheets.Add     'aggiunge un nuovo foglio per la pivot
    
    UltimaRiga = wshOutData.Range("A1").End(xlDown).Row
    UltimaColonna = wshOutData.Range("A1").End(xlToRight).Column
            
' cerco la data massima della scadenza
    DataMax = Application.WorksheetFunction.Max(wshOutData.Range("p:p"))
' cerco la data minima della scadenza
    DataMin = Application.WorksheetFunction.Min(wshOutData.Range("P:p"))
    
    Set objPCch = wbOut.PivotCaches. _
        Add(xlDatabase, SourceData:=wshOutData.Range(wshOutData.Cells(1, 1), wshOutData.Cells(UltimaRiga, UltimaColonna)))
        
    Set objPTbl = objPCch.CreatePivotTable _
        (wshOutPivot.Range("A1"), TableName:="CLIENTE_SCADENZE", DefaultVersion:=xlPivotTableVersion10)

      
' aggiungo i campi relativi ai dati

    With objPTbl.PivotFields("Importo in Val")
        .Orientation = xlDataField
        .Caption = "Tot. in Val"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Contanti")
        .Orientation = xlDataField
        .Caption = "Contanti €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Altro")
        .Orientation = xlDataField
        .Caption = "Altro €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
 objPTbl.DataPivotField.Orientation = xlColumnField
 
'formatta il campo data nel foglio 1
    
    wshOutData.Columns("p:p").NumberFormat = _
    "dd/mm/yy;@"
    objPTbl.PivotCache.Refresh


   With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
        .Caption = "Scad"
    End With

'raggruppa per Trimestre e Mese il campo Data

    Set groupRange = objPTbl.PivotFields("SCAD") _
                            .DataRange
        
            groupRange.Cells(1).Group _
            Start:=DataMin, End:=DataMax, _
            Periods:=Array(False, False, False, _
            True, True, False, True)

       
 ' inserisco i campi riga
  objPTbl.AddFields RowFields:= _
        Array("Cliente", "Società", "Div", "scad")
 
 
'inserisco i campi pagina

    With objPTbl.PivotFields("Anni")
        .Orientation = xlPageField
        .Caption = "Anni"
    End With

    With objPTbl.PivotFields("INTERCOMPANY")
        .Orientation = xlPageField
        .Caption = "CONSO"
        .CurrentPage = "TERZI"
    End With
  
' evidenzio i totali
   ActiveSheet.PivotTables("CLIENTE_SCADENZE").PivotSelect _
        "Cliente[All;Total] Terzi", xlDataAndLabel, True
    With Selection
        .Font.Bold = True
        .Font.Size = 10
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
        

'nascondiamo i dettagli della pivot
    objPTbl.PivotSelect "'Cliente'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotSelect "'Società'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotCache.Refresh
'    wshOutData.Visible = True
    Cells.EntireColumn.AutoFit
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.DisplayAutomaticPageBreaks = False

'=====================================
'
' INSERISCO LA SECONDA PIVOT
'
'=====================================

MsgBox ("creo la seconda pivot")


Set wshOutPivot = wbOut.Worksheets.Add     'aggiunge un nuovo foglio per la pivot
Set objPTbl = objPCch.CreatePivotTable _
        (wshOutPivot.Range("A1"), TableName:="SCADENZE_CLIENTE", DefaultVersion:=xlPivotTableVersion10)

' aggiungo i campi relativi ai dati

    With objPTbl.PivotFields("Importo in Val")
        .Orientation = xlDataField
        .Caption = "Tot Valuta"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Contanti")
        .Orientation = xlDataField
        .Caption = "Contanti €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
 objPTbl.DataPivotField.Orientation = xlColumnField
 
 With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
 End With

'raggruppa per Trimestre - Mese - Giorno il campo Data
    
    Set groupRange = objPTbl.PivotFields("SCADENZA") _
                            .DataRange
        
            groupRange.Cells(1).Group _
            Start:=DataMin, End:=DataMax, _
            Periods:=Array(False, False, False, _
            True, True, False, True)

' inserisco i campi riga
    With objPTbl
        .AddFields RowFields:=Array("Mesi", "Cliente", "Fattura", "Data Ft", "scadenza")


    End With
    
    With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
        .Caption = "Data Scadenza"
        .NumberFormat = "gg/mm/aa"
    End With
 
 'inserisco i campi colonna
 With objPTbl.PivotFields("Div")
        .Orientation = xlColumnField
        .Caption = "Valuta"
        .Position = 1
 End With

'inserisco i campi pagina

    With objPTbl.PivotFields("Anni")
        .Orientation = xlPageField
        .Caption = "Anni"
    End With

    With objPTbl.PivotFields("INTERCOMPANY")
        .Orientation = xlPageField
        .Caption = "CONSO"
        .CurrentPage = "TERZI"
    End With
    
    With objPTbl.PivotFields("SCADUTO")
        .Orientation = xlPageField
        .CurrentPage = "scaduto"
    End With
    objPTbl.PivotFields("Data Scadenza"). _
        Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
        False, False)
    objPTbl.PivotFields("Data Ft").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Fattura").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Cliente").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Mesi").Subtotals = _
        Array(True, False, False, False, False, False, False, False, False, False, False, False)

' evidenzio i totali
    ActiveSheet.PivotTables("SCADENZE_CLIENTE").PivotSelect "Mesi[All;Total] Terzi" _
        , xlDataAndLabel, True
    With Selection
        .Font.Bold = True
        .Font.Size = 10
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
        

'nascondiamo i dettagli della pivot
    objPTbl.PivotSelect "'mesi'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotSelect "'Cliente'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotCache.Refresh
    wshOutData.Visible = True
    Cells.EntireColumn.AutoFit
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.DisplayAutomaticPageBreaks = False
    Application.ScreenUpdating = True
'=====================================
'
' INSERISCO LA TERZA PIVOT
'
'=====================================

MsgBox ("creo la terza pivot")


Set wshOutPivot = wbOut.Worksheets.Add     'aggiunge un nuovo foglio per la pivot
Set objPTbl = objPCch.CreatePivotTable _
        (wshOutPivot.Range("A1"), TableName:="SOCIETA_SCADENZE_CLIENTE", DefaultVersion:=xlPivotTableVersion10)

' aggiungo i campi relativi ai dati

    With objPTbl.PivotFields("Importo in Val")
        .Orientation = xlDataField
        .Caption = "Tot Valuta"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
    With objPTbl.PivotFields("Contanti")
        .Orientation = xlDataField
        .Caption = "Contanti €"
        .Function = xlSum
        .NumberFormat = "#,##0;[Red](#,##0)"
    End With
    
 objPTbl.DataPivotField.Orientation = xlColumnField
 
 With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
 End With

'raggruppa per Trimestre - Mese - Giorno il campo Data
    
    Set groupRange = objPTbl.PivotFields("SCADENZA") _
                            .DataRange
        
            groupRange.Cells(1).Group _
            Start:=DataMin, End:=DataMax, _
            Periods:=Array(False, False, False, _
            True, True, False, True)

' inserisco i campi riga
    With objPTbl
        .AddFields RowFields:=Array("Mesi", "Cliente", "Fattura", "Data Ft", "scadenza")


    End With
    
    With objPTbl.PivotFields("Scadenza")
        .Orientation = xlRowField
        .Caption = "Data Scadenza"
        .NumberFormat = "gg/mm/aa"
    End With
 
 'inserisco i campi colonna
 With objPTbl.PivotFields("Div")
        .Orientation = xlColumnField
        .Caption = "Valuta"
        .Position = 1
 End With

'inserisco i campi pagina

    With objPTbl.PivotFields("Anni")
        .Orientation = xlPageField
        .Caption = "Anni"
    End With

    With objPTbl.PivotFields("INTERCOMPANY")
        .Orientation = xlPageField
        .Caption = "CONSO"
        .CurrentPage = "TERZI"
    End With
    
    With objPTbl.PivotFields("SCADUTO")
        .Orientation = xlPageField
        .CurrentPage = "scaduto"
    End With
    With objPTbl.PivotFields("Società")
        .Orientation = xlPageField
    End With
    
    objPTbl.PivotFields("Data Scadenza"). _
        Subtotals = Array(False, False, False, False, False, False, False, False, False, False, _
        False, False)
    objPTbl.PivotFields("Data Ft").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Fattura").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Cliente").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    objPTbl.PivotFields("Mesi").Subtotals = _
        Array(True, False, False, False, False, False, False, False, False, False, False, False)

' evidenzio i totali
    ActiveSheet.PivotTables("SOCIETA_SCADENZE_CLIENTE").PivotSelect "Mesi[All;Total] Terzi" _
        , xlDataAndLabel, True
    With Selection
        .Font.Bold = True
        .Font.Size = 10
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
        

'nascondiamo i dettagli della pivot
    objPTbl.PivotSelect "'mesi'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotSelect "'Cliente'[All]", xlLabelOnly, True
    Selection.ShowDetail = True
    objPTbl.PivotCache.Refresh
    wshOutData.Visible = True
    Cells.EntireColumn.AutoFit
    ActiveWindow.DisplayGridlines = False
    ActiveSheet.DisplayAutomaticPageBreaks = False
    Application.ScreenUpdating = True

MsgBox ("Creo tabella singola società")

ActiveSheet.PivotTables("SOCIETA_SCADENZE_CLIENTE").ShowPages PageField:="Società"

Sheets.Select
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireColumn.AutoFit

MsgBox ("Estrazione terminata")
End Sub

di Vecchio Frac data: 22/11/2012 22:06:40
Non me ne ero disinteressato, a parziale discolpa purtroppo ho dovuto anteporre il lavoro :)
Complice il fatto che sulla mia macchina non gira come vedo dal risultato, avevo raggiunto un'implementazione leggermente diversa dell'inizio procedura, la posterò volentieri.

Sull'errore di Range(Cells(i, 23), Cells(i, 23)), hai pienamente ragione, l'avevo corretto nel mio file ma poi ho sbadatamente dimenticato di informarti!! mi sembrava un errore talmente banale ed evidente che non mi è venuto in mente che avrebbe potuto creare dei problemi.
Non mi piace la tua versione per inserire le intestazioni e le formule dei campi - la mia è più generica e non crea formule, ma calcola direttamente i risultati. Vedremo come convincerti :)
Sulle pivot, ho visto il file risultante e se te le crea così vanno benissimo, in realtà è un macello leggere questo codice nudo e crudo, ci fidiamo sulla parola ;)

In ogni caso, i miei complimenti a te per averci sbattuto il naso e aver trovato il modo di aggiustare da solo la procedura affinchè il Do facesse quel che volevi!
di rplacanica (utente non iscritto) data: 23/11/2012 09:51:37
Grazie!
il mio non voleva essere un richiamo, è solo che ci terrei particolarmente visto che solo con i suggerimenti di chi è più bravo si impara a crescere.
L'struzione per l'inserimento delle intestazioni l'ho presa dal tuo suggerimento sull'altro post.
Per le formule ho provato ad inserire la tua proposta ma mi segnalava alcuni errori e quindi, per fretta ho riproposto la mia versione.
Le pivot....arrivano da un altro testo, questa volta di Giancarlo Floria.
grazie ancora e buon Venerdì
di rplacanica (utente non iscritto) data: 23/11/2012 15:20:02
cit-->Vecchio Frac
Non mi piace la tua versione per inserire le intestazioni e le formule dei campi - la mia è più generica e non crea formule, ma calcola direttamente i risultati. Vedremo come convincerti :)

ho provato, ma ci mette una eternità ... e la ventola va a manetta.
On Error Resume Next
For i = 2 To LAST_ROW
'colonna P
Cells(i, 16) = IIf(Left(Cells(i, 1), 8) = "Scadenza", Cells(i, 2), Cells((i - 1), 16))
Cells(i, 16).NumberFormat = "dd-mm-yy"
'colonna Q
Cells(i, 17) = Year(Cells(i, 16))
'colonna R
Cells(i, 18) = Month(Cells(i, 16))
'colonna S
Cells(i, 19) = IIf(Cells(i, 3) <> 0, Cells(i, 3), "")
Cells(i, 19).NumberFormat = "dd-mm-yy"
'colonna T
Cells(i, 20) = IIf(Cells(i, 7) And Cells(i, 3), "VERO", "FALSO")
'colonna U
Cells(i, 21) = DatePart("ww", Cells(i, 16))
'colonna V
Cells(i, 22) = IIf(Cells(i, 7) < DATESCAD, "scaduto", "a scadere")
Next
On Error GoTo 0
con la mia stringa ci mette pochi istanti poi copia e incolla i valori e via...
vorrei conoscere il beneficio derivante dalla tua notazione.
:)
di Vecchio Frac data: 23/11/2012 15:47:26
LOL, tendenzialmente il codice lavora in memoria e non direttamente in cella, deve per forza essere più veloce :)
E' abbastanza strano sia l'impegno della CPU che il rallentamento delle prestazioni.
Do la colpa a IIf, è un operatore che non mi piace anche se qualche utilità ce l'ha ;)
Alle volte si rimane stupiti da quanto siano infondate le proprie convinzioni sopratutto se ti dimostrano che... hai torto :D

Vuoi Approfondire?