Realizzazione Macro per recupero dati

Question

Ciao David

Ho una domanda porvi

Mi serve un comando macro per fare in modo che delle informazioni contenute in un riga qualsiasi di un foglio definito di "inserimento dati"  venga copiata come singola riga e poi trasferita in un foglio a parte di elaborazione dati e ogni volta tale riga venga incollata nella prima riga libera che trova nel foglio di destinazione, la mia difficoltà nel riuscire a fare tale comando sta nel fatto che la riga da copiare dal foglio di inserimento dati può essere ogni volta diversa e compresa tra la riga 2 e la riga 200 la riga da copiare deve essere subordinata al clik effettuato su un collegamento ipertestuale contenuto nella colonna B il quale è presente in tutte le righe dalla 2 all 200 e cliccando sul quale si va ad elaborare un documento in PDF.

Spero di essere stato abbastanza chiaro

se hai problemi fammi sapere

ciao Cristian

Answer 1

Ciao Cristian,

Const sColonne_da_Copiare As String = "A:AV"                 '<<=== Modifica

    Const sFoglio_Destinazione As String = "Foglio3"           '<<=== Modifica 

Il foglio 3 lo richiamerò io come mi servirà in seguito

Ho scaricato il tuo file e credo che il problema principale sia che sul foglio Inserimento dati siano presenti righe nascoste.

Per superare il problema, nel modulo di codice del foglio Inserimento datiincolla il seguente codice:

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

Option Explicit

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

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

    Dim destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim LRow As Long

    Const sColonne_da_Copiare As String = "A:AV"                 '<<=== Modifica

    Const sFoglio_Destinazione As String = "Foglio3"              '<<=== Modifica

    Set srcRng = Intersect(ActiveCell.EntireRow, _

                           Me.Columns(sColonne_da_Copiare))

    Set destSH = ThisWorkbook.Sheets(sFoglio_Destinazione)

    With destSH

        Debug.Print Target.Range.Cells.Count

        LRow = LastRow(destSH, .Columns(sColonne_da_Copiare))

        Set destRng = .Range("A" & LRow + 1)

    End With

    srcRng.Copy Destination:=destRng

End Sub

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

In un modulo standard, incolla:

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

Option Explicit

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

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

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

===

Regards,

Norman

Answer 2

Scusa se disturbo

ma sembra non funzionare comunque,

non ho capito bene come farla funzionare occorre aggiungere parti, o info.

ciao

Answer 3

Ciao Cristian,

Ciao la macro sembra non funzionare

si pianta in questo punto

LRow = LastRow(destSH, .Columns("A:A"))

Ho provato a modificare qualcosa ma non trovo soluzioni 

[...]

Mea culpa, ho dimenticato di pubblicare parte del mio codice!! 

In un modulo standard, incolla la segente funzione:

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

Option Explicit

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

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

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

===

Regards,

Norman

Answer 4

Ciao la macro sembra non funzionare

si pianta in questo punto

LRow = LastRow(destSH, .Columns("A:A"))

Ho provato a modificare qualcosa ma non trovo soluzioni

tra le altre cose ti mando una immagine dell file per essere più chiaro

cliccando su linck DIPENDENTE 1 (così come per ogni altro lick dipendente) deve copiare la sua riga corrispondente da A a AV

e incollarla la stessa in un foglio a parte ovviamente non sovrascrivendo ma mettendole una sotto l'altra  sotto la prima vuota partendo dalla 3 riga in poi in modo da poter inserire in po di intestazione

 se fosse poi possibile si riesce nella colonna A DATA  nella cella specifica delle riga copiata è possibile inserire la data del giorno in cui si svolge l'azione di copia e incolla ? 

grazie per la tua grande disponibilità

buona giornata

Answer 5

Ciao Cristian,

Ciao David

Ho una domanda porvi

Mi serve un comando macro per fare in modo che delle informazioni contenute in un riga qualsiasi di un foglio definito di "inserimento dati"  venga copiata come singola riga e poi trasferita in un foglio a parte di elaborazione dati e ogni volta tale riga venga incollata nella prima riga libera che trova nel foglio di destinazione, la mia difficoltà nel riuscire a fare tale comando sta nel fatto che la riga da copiare dal foglio di inserimento dati può essere ogni volta diversa e compresa tra la riga 2 e la riga 200 la riga da copiare deve essere subordinata al clik effettuato su un collegamento ipertestuale contenuto nella colonna B il quale è presente in tutte le righe dalla 2 all 200 e cliccando sul quale si va ad elaborare un documento in PDF.

Prova qualcosa del genere:

• Fai clic dx sulla linguetta del foglio di interesse
• Seleziona l'opzione Visualizza Codice dal **** menu contestuale risultante
• Incolla il seguente codice:

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

Option Explicit

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

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

    Dim destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim LRow As Long

    Const sColonne_da_Copiare As String = "A:D"                 '<<=== Modifica

    Const sFoglio_Destinazione As String = "Foglio2"           '<<=== Modifica 

    Set srcRng = Intersect(Target.Range.EntireRow, Me.Columns(sColonne_da_Copiare))

    Set destSH = ThisWorkbook.Sheets(sFoglio_Destinazione)

    With destSH

        LRow = LastRow(destSH, .Columns("A:A"))

        Set destRng = .Range("A" & LRow + 1)

    End With

    srcRng.Copy Destination:=destRng

End Sub

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

• Alt+Q per chiudere l'editor di VBA e tornare a Excel.
• Salva il file con l'estensione xlsm.

===

Regards,

Norman