Formattazione destinazione

Question

Utilizzo la sottostante macro per copiare un range di celle non vuote dal foglio"data" , al foglio "QTR" . Mi servirebbe integrare la macro in modo che le celle copiate assumano la formattazione di destinazione.

Inoltre, se possibile, che le celle copiate vengano inserite nel nuovo foglio (a partire da D12), spostando in basso tutte le righe sottostanti.

Cordiali saluti.

Sub DATACopy()

With Sheets("data").Range("G1:N100")

    Application.Intersect(.SpecialCells(xlCellTypeVisible), _

          .SpecialCells(xlCellTypeConstants)).copy _

               Destination:=Sheets("QTR").Range("D12")

End With

End Sub

Answer 1

Ciao Norman

funziona perfettamente. Per completare al meglio , ora devo rimuovere le righe uguali ;

• l' intervallo di selezione va da B12 a P (intera colonna);
• mentre la colonna contenente i duplicati è la E

Grazie

Ciao Zulu,

Penso che questa sia una domanda separata e distinta; l'unico vero nesso che posso vedere è che entrambe le domande si riferiscono alla stessa cartella di lavoro. Posterò una soluzione a condizione che, in futuro, cercherai di aprire un thread separato per ogni domanda. Questo ti aiuterà, perché è probabile che  riceverai più risposte utili e aiuterà anche chi avra bisogno di cercare negli archivi del forum per una soluzione a un problema simile.

A lavoro!

Alt-F11 per aprire l'editor di VBA

Alt-IM per inserire un nuovo modulo di codice

Nel nuovo modulo vuoto, incolla il seguente codice:

'========>>

Option Explicit

'-------->>

Public Sub DeleteRange()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim rCell As Range

    Dim delRng As Range

    Dim iLastRow As Long

    Dim oDic As Object

    Dim CalcMode As Long

    On Error GoTo ErrHandler

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("QTR")

    With SH

        iLastRow = SH.Cells(Rows.Count, "A").End(xlUp).Row

        Set Rng = SH.Range("E12:E" & iLastRow)

    End With

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set oDic = CreateObject("Scripting.Dictionary")

    oDic.CompareMode = vbTextCompare

    For Each rCell In Rng.Cells

        With rCell

            If Not oDic.exists(.Value) Then

                oDic.Add Key:=.Value, Item:=.Value

            Else

                If delRng Is Nothing Then

                    Set delRng = rCell

                Else

                    Set delRng = Union(rCell, delRng)

                End If

            End If

        End With

    Next rCell

    If Not delRng Is Nothing Then

        Intersect(delRng.EntireRow, SH.Columns("B:P")).Delete Shift:=xlUp

    Else

        'nothing found, do nothing

    End If

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

    On Error GoTo 0

    Exit Sub

ErrHandler:

    Call MsgBox(Prompt:="Error " _

                        & Err.Number _

                        & " (" _

                        & Err.Description _

                        & ") nella routine: DeleteRange", _

                Buttons:=vbCritical, _

                Title:="ERRORE")

    Resume XIT

End Sub

'-------->>

Function LastRow(SH As Worksheet, _

                 Optional Rng As Range)

    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

End Function

'<<========

Alt-Q per chiudere l'editor di VBA

Alt-F8 per aprire la finestrina macro

Seleziona DeleteRange | Esegui

===

Regards,

Norman

Answer 2

Ciao Norman

funziona perfettamente. Per completare al meglio , ora devo rimuovere le righe uguali ;

• l' intervallo di selezione va da B12 a P (intera colonna);
• mentre la colonna contenente i duplicati è la E

Grazie

Answer 3

Hai ragione ; se una cella dell'intervallo è vuota la macro si blocca. Per il resto, quello che voglio è semplicemente copiare l'intero intervallo di celle G1:N100 (quindi anche celle vuote intermedie, escludendo solo le righe interamente vuote) nel foglio QTR con punto di inserimento in D12 (quindi se G1 è vuota anche D12 è vuota, e poi seguono tutti i valori copiati dell' intervallo).

Facendo questo le celle copiate dovrebbero assumere la formattazione di destinazione, e spostare in basso le intere righe esistenti del foglio QTR.

Grazie per la pazienza.

Ciao Zulu,

Prova qualcosa del genere:

'==========>>

Option Explicit

'---------->>

Sub DATACopy()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim rRow As Range

    Dim arrIn() As Variant

    Dim i As Long, j As Long, k As Long

    Dim iLastrow As Long

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets("Data")

        Set destSH = .Sheets("QTR")

    End With

    With srcSH

        iLastrow = LastRow(srcSH, .Columns("G:N"))

        Set srcRng = .Range("G1:N" & iLastrow)

    End With

    Set destRng = destSH.Range("D12")

    With srcRng

        k = .Columns.Count

        ReDim arrIn(1 To k, 1 To .Rows.Count)

        For Each rRow In .Rows

            If rRow.Hidden = False Then

                i = i + 1

                For j = 1 To UBound(arrIn, 1)

                    arrIn(j, i) = rRow.Cells(j).Value

                Next j

            End If

        Next rRow

        ReDim Preserve arrIn(1 To k, 1 To i)

    End With

    With destRng

        .Resize(i, k).Insert shift:=xlDown

        .Offset(-i).Resize(i, k).Value = Application.Transpose(arrIn)

    End With

End Sub

'---------->>

Function LastRow(SH As Worksheet, _

                 Optional Rng As Range)

    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

End Function

'<<==========

Answer 4

Hai ragione ; se una cella dell'intervallo è vuota la macro si blocca. Per il resto, quello che voglio è semplicemente copiare l'intero intervallo di celle G1:N100 (quindi anche celle vuote intermedie, escludendo solo le righe interamente vuote) nel foglio QTR con punto di inserimento in D12 (quindi se G1 è vuota anche D12 è vuota, e poi seguono tutti i valori copiati dell' intervallo).

Facendo questo le celle copiate dovrebbero assumere la formattazione di destinazione, e spostare in basso le intere righe esistenti del foglio QTR.

Grazie per la pazienza.

Answer 5

Utilizzo la sottostante macro per copiare un range di celle non vuote dal foglio"data" , al foglio "QTR" . Mi servirebbe integrare la macro in modo che le celle copiate assumano la formattazione di destinazione.

Inoltre, se possibile, che le celle copiate vengano inserite nel nuovo foglio (a partire da D12), spostando in basso tutte le righe sottostanti.

Cordiali saluti.

Sub DATACopy()

With Sheets("data").Range("G1:N100")

    Application.Intersect(.SpecialCells(xlCellTypeVisible), _

          .SpecialCells(xlCellTypeConstants)).copy _

               Destination:=Sheets("QTR").Range("D12")

End With

End Sub

Ciao Zulu.

Credo che tuo codice si bloccherebbe  se ci fossero alcune - ma non tutte - celle vuote in qualsiasi delle righe nell'intervallo da copiare. Per dimostrare questo, cancella il contenuto della prima cella in questo intervallo, cioè G1 e poi avvia la macro. 

Quindi, nel caso in cui fosse possible trovare delle celle vuote nelle righe visibili, come  dovreste essere effettuata la copia? In altre parole, nel caso in cui la prima cella G1 dell'intervallo da copiare fosse vuoto, quale cella dovrebbe essere copiato nella cella D12 sul foglio QTR?

===

Regards,

Norman