VBA (Copia&Formatta)

[mflautoPartecipante mflauto Karma: 1 pt]

Buongiorno a tutti,

ho adattato una serie di macro per copiare e formattare dei dati tabellari estratti da un database da un foglio di input chiamato "DATI" in un foglio destinazione chiamato "REGPortale" vorrei che quando copio i dati dal foglio sorgente al foglio di destinazione i dati nel foglio sorgente non venissero modificati (devono rimanere i dati originali perchè poi si serviranno per utilizzare altre formattazioni in altri fogli).

In allegato il file di esempio.

Grazie per l'aiuto.

Option Explicit

Public Sub Formatta_Registro()
   On Error Resume Next
    If MsgBox("Eseguire Copia & Formatta?", vbYesNo) = vbNo Then 'seve per interrompere la macro nle caso si scriva "no"
    Exit Sub
    End If
    Dim WB As Workbook
    Dim srcSH As Worksheet, destSH As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim Rng As Range, rArea As Range
    Dim LRow As Long
    Dim CalcMode As Long
    Dim sPrimaCellaDestinazione As String
    Dim ur As Long
        
    Const sFoglioSorgente As String = "DATI"               '<<=== copia dal foglio sorgente
    Const sFoglioDestinazione As String = "REGPortale"       '<<=== al foglio destinazione
    Const sColonneDaCopiare As String = "A2:G2"                '<<=== il range di celle che deve esssere copiato
    'sPrimaCellaDestinazione = InputBox("Inserire i Riferimenti della Cella dove verranno Copiati i Dati?")   'chiedo la cella dove incollare i dati del foglio SorgenteDati
    
    Windows("DATI").Activate
    Worksheets("DATI").Activate ' attiva il foglio "DATI"
    Range("B:J,L:M,O:R,T:U,X:X").EntireColumn.Delete                               'elimina le colone selezionate
    Range("A1:G1").Select  ' Selezione delle celle
    Selection.AutoFilter   ' Inserimento del filtro
    ActiveSheet.Range("$A$1:$G$213").AutoFilter Field:=3, Criteria1:="=200140" _
        , Operator:=xlOr, Criteria2:="=200307"
     Columns("A:G").Select
    ActiveWorkbook.Worksheets("DATI").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("DATI").Sort.SortFields.Add2 Key:=Range("E2:E213") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("DATI").Sort.SortFields.Add2 Key:=Range("F2:F213") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("DATI").Sort
        .SetRange Range("A1:G213")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Worksheets("RGPortale").Activate ' attiva il foglio "RGPortale"
   
    Set WB = ThisWorkbook
    With WB
        Set srcSH = .Sheets(sFoglioSorgente)
        Set destSH = .Sheets(sFoglioDestinazione)
        ur = destSH.Cells(destSH.Rows.Count, "A").End(xlUp).Row
        sPrimaCellaDestinazione = "A" & ur + 1
    End With

    With srcSH
        LRow = LastRow(srcSH, .Columns("A:A"))
        Set srcRng = .Range(sColonneDaCopiare)
    End With

    Set destRng = destSH.Range(sPrimaCellaDestinazione)
    On Error GoTo XIT
      With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    For Each rArea In srcRng.Areas
        Set Rng = rArea.Resize(LRow)
        Rng.Copy Destination:=destRng
        Set destRng = destRng.Offset(0, Rng.Columns.Count)
    Next rArea
    
        Call MsgBox( _
             Prompt:="Formattazione e Copia Completata!", _
             Buttons:=vbInformation, _
             Title:="REPORT")
            

XIT:
    With Application
        .Calculation = CalcMode
        .ScreenUpdating = True
    End With
   
 
End Sub

'--------->>
Public Function LastRow(SH As Worksheet, _
                        Optional Rng As Range, _
                        Optional minRow As Long = 1)
    If Rng Is Nothing Then
        Set Rng = SH.Cells
    End If

    On Error Resume Next
    LastRow = Rng.Find(What:="*", _
                       After:=Rng.Cells(1), _
                       LookAt:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
    On Error GoTo 0
    If LastRow < minRow Then
        LastRow = minRow
    End If
End Function

Massimiliano

Allegati:

You must be logged in to view attached files.

[Autore]

Articoli