You are here:---Rispondi a: [RISOLTO] Aggiunta di dati tramite macro per tabella Excel
Rispondi a: [RISOLTO] Aggiunta di dati tramite macro per tabella Excel 2018-11-08T13:18:15+00:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Aggiunta di dati tramite macro per tabella Excel Rispondi a: [RISOLTO] Aggiunta di dati tramite macro per tabella Excel

sidsid
Moderatore
    Post totali: 440

    Prova la macro così modificata:

    Sub crea_report2() 'SITUAZIONE FATTURAZIONE CLIENTI
    Application.ScreenUpdating = False
    Dim wb As Workbook
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ultC As Long, j As Long
    Dim riga As Long, riga2 As Long
    Dim Ws As Worksheet
    Dim aperto As Boolean
    Dim jj As Long
    Dim aBordi As Variant
    aBordi = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    
    'VERIFICO SE IL FILE "Schede Clienti.xlsm" è APERTO
    For Each wb In Application.Workbooks
        If wb.Name = "SCHEDE CLIENTI.xlsm" Then
            aperto = True
            Set wb1 = Workbooks("SCHEDE CLIENTI.xlsm")
            Exit For
        End If
    Next wb
    
    'SE è CHIUSO LO APRO
    If Not aperto Then
       Set wb1 = Workbooks.Open("C:\FATTURAZIONE\SCHEDE CLIENTI.xlsm")
    End If
    
    'Set wb1 = Workbooks("Schede Clienti.xlsm")
    Set wb2 = Workbooks.Add
    riga = 3
    riga2 = riga + 1
    
    ' On Error GoTo uscita
    'FORMATTO IL FOGLIO1 DEL NUOVO FILE
    With wb2.Sheets("Foglio1")
        .Range("A1").Value = "SITUAZIONE FATTURAZIONE CLIENTI AL " & Date
        With .Range("A1:D1")
            .Borders.Weight = xlMedium
            .Borders.LineStyle = xlContinuous
            .Merge
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        End With
        .Range("A2").Value = "CLIENTE"
        .Range("B2").Value = "ULTIMO PERIODO FATTURATO"
        .Range("C2").Value = "PERIODO DA FATTURARE"
        .Range("D2").Value = "COSTO"
        .Rows(1).RowHeight = 25
        With .Range("A2:D2")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlMedium
        End With
    End With
    
    'CICLO I FOGLI DEL FILE PRINCIPALE
    For Each Ws In wb1.Worksheets
        With wb1.Sheets(Ws.Name)
            ultC = IIf(.Range("C3").Value = "", 3 _
            , .Range("C" & Rows.Count).End(xlUp).Row)
            With wb2.Sheets("Foglio1")
                    
                    'INSERIMENTO DATI
                    .Range("A" & riga).Value = wb1.Sheets(Ws.Name).Range("A1").Value
                    If wb1.Sheets(Ws.Name).Range("C3") = "" Then
                        With .Range("B" & riga)
                            .Value = "MAI FATTURATO"
                            '.Interior.ColorIndex = 3 'colore fondo cella
                            '.Font.ColorIndex = 2 ' colore carattere
                        End With
                    Else
                        .Range("B" & riga).Value = wb1.Sheets(Ws.Name).Range("C" & ultC).Value
                    End If
                    .Range("D" & riga).Value = wb1.Sheets(Ws.Name).Range("h1").Value 'COSTO
                    riga = riga + 1
            End With
        End With
    Next Ws
    
    'CHIUDO IL FILE "SCHEDE_CLIENTI.xlsm"
    wb1.Close
    
    'ADATTO LA LARGHEZZA DELLE COLONNE.
    'SELEZIONO IL TITOLO.
    'ADATTO I MARGINI PER LA STAMPA
    
    With wb2.Sheets("Foglio1")
        .Columns("A:D").AutoFit
        .Range("A1:D1").Select
    'End With
        With .PageSetup
            .LeftMargin = Application.InchesToPoints(0.26)
            .RightMargin = Application.InchesToPoints(0.34)
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .Orientation = xlLandscape ' foglio orizzontale
        End With
    
    'Ordinamento database
        .Sort.SortFields.Add Key:=.Range("A3:A200") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange wb2.Sheets("Foglio1").Range("A2:D200")
            .Header = xlYes
            .MatchCase = False
            .SortMethod = xlPinYin
            .Apply
        End With
    
    'INSERIMENTO DOPPIA RIGA, BORDI E FONDO ROSSO
        For j = riga - 1 To riga2 Step -1
            .Rows(j).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            For jj = LBound(aBordi) To UBound(aBordi)
                With .Range("A" & j + 1 & ":D" & j + 2).Borders(aBordi(jj))
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
            Next jj
            With .Range("B" & j + 1)
                If .Value = "MAI FATTURATO" Then
                    .Interior.ColorIndex = 3 'colore fondo cella
                    .Font.ColorIndex = 2 ' colore carattere
                End If
            End With
        Next j
        
        For jj = LBound(aBordi) To UBound(aBordi)
            With .Range("A3:D4").Borders(aBordi(jj))
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        Next jj
        With .Range("B3")
            If .Value = "MAI FATTURATO" Then
               .Interior.ColorIndex = 3 'colore fondo cella
               .Font.ColorIndex = 2 ' colore carattere
            End If
        End With
    End With
    Set wb1 = Nothing
    Set wb2 = Nothing
    
    Application.ScreenUpdating = True
    End Sub

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi