selezionare la cella pari della colonna A pari e spostarla nella colonna B pari-1

Question

ho un foglio in cui in colonna A nella cella dispari (A(2n-1) per n=1....) ho una foto e in quella pari (A2n) il nome e cognome.

Vorrei spostare nome e cognome nella colonna B quindi a fianco della foto (B(2n-1)) e cancellare le righe pari.

Spero di essere stato chiaro.

PS - premetto che il tutto è stato copiato da internet ed era già strutturato come vorrei, ma non so come mai, il nome e cognome è slittato sotto la foto.

Avrei potuto adottare qualche accorgimento per evitare il lavoro di cui sopra?

Answer 1

Ciao Mario,

mi chiedevo se ci sono limiti al n di righe. 

Ho completato l'elenco che è di 2520 righe ho applicato la tua routine ma compare questo alert

dando ok il risultato è molto confuso e comunque diverso da quello ottenuto con poche righe.

Prova con questo che è compresso

https://1drv.ms/u/s!Atay-0SPRs4igQ7KaiLvg9FzeIOA

L'errore che hai riscontrato è un errore generico ma, in questa istanza, credo che sia dovuto ad una mancanza di risorsi.

A questo proposito, non mi stupisce che hai riscontrato un errore visto che il file pesa 22 MB e comprende 2520 collegamenti ipertestuali e 630 foto!

Pertanto, vorrei suggerire di riavviare il tuo Mac e rieseguire il codice, dopo aver chiuso eventuali altri programmi.

Se dovessi ancora riscontrare lo stesso problema, prova a sostituire il codice precedente con la seguente versione:

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim LRow As Long, i As Long, j As Long

    Dim CalcMode As Long

    Const sFoglio As String = "Foglio1"        '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    With SH

        .UsedRange.SpecialCells(xlCellTypeBlanks).Delete

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

        Set Rng = .Range("A1:A" & LRow)

        .Rows(1).Resize(LRow / 3).RowHeight = .Pictures(1).Height + 4

    End With

    j = SH.Pictures.Count

    With Rng

        .Columns("A").EntireColumn.ColumnWidth = 14.75

        .Columns("B:C").VerticalAlignment = xlCenter

        For i = LRow To 1 Step -3

            .Cells(i - 2).Resize(2).Copy

            .Cells(i - 2, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True

            .Cells(i - 1).Resize(2, 3).Delete Shift:=xlUp

            Set oPic = SH.Pictures(j)

            oPic.Top = .Cells(i - 2).Top

            oPic.Left = .Cells(i - 2).Left

            oPic.Placement = 2

            j = j - 1

        Next i

        .Columns("A").Clear

        With .Columns("B:C")

            .EntireColumn.AutoFit

            .VerticalAlignment = xlCenter

        End With

    End With

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, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    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

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

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

Tuttavia, mi sembra possibile che il file ottenuto come risultato dell'esecuzione, senza problemi, del codice possa essere sufficiente per i tuoi scopi e, qualora questa ipotesi fosse vera, puoi scaricare il seguente file:

                              Marco20180331.zip

===

Regards,

Norman

Answer 2

Ciao mfrisco0,

non mi è chiaro quello che mi chiedi con:

Per chiudere questo thread, vorrei chiederti gentilmente di contrassegnare la mia risposta come Risposta. In questo modo, tu aiuterai anche coloro che potessero cercare soluzioni ai problemi simili negli archivi della Community.

forse intendi che io risponda al quesito

Il problema è stato risolto?  Sì   No

Credo di sì.

Vorrei chiederti un'ultima curiosità per quanto riguarda la camera si presenta una situazione di questo tipo:

vorrei che di fianco alla foto compaia:

• nome e cognome in colonna B
• il partito in colonna C
• cancellare la "scrivi" e le 2 righe precedenti
• mantenere i collegamenti ipertestuali.

Potresti nel creare il VBA commentare le istruzioni che interessano ciascuna delle tre operazioni? vorrei in caso di ulteriori aggiunte di informazioni potermela cavare in autonomia.  

Il link al file è:

https://1drv.ms/x/s!Atay-0SPRs4igQpgF39HtPDKhl\_W

Prova qualcosa del genere:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, RngTemp As Range

    Dim oPic As Picture

    Dim i As Long, j As Long, LRow As Long

    Dim dHeight As Double, dLeft As Double, dTop As Double

    Const sFoglio As String = "Foglio1"        '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    Application.ScreenUpdating = False

    With SH

        dHeight = .Pictures(1).Height

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

        Set Rng = .Range("A1:A" & LRow)

        On Error Resume Next

        Set RngTemp = Rng.SpecialCells(xlCellTypeBlanks)

        On Error GoTo 0

        If Not RngTemp Is Nothing Then

            RngTemp.Delete Shift:=xlUp

        End If

        .Columns(1).Insert

        .Columns(1).ColumnWidth = 14.75

        LRow = .Cells(Rows.Count, "B").End(xlUp).Row

        Set Rng = .Range("B1:B" & LRow)

    End With

    With Rng

        .EntireColumn.ColumnWidth = 30

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlCenter

        .IndentLevel = 1

        With .Offset(, -1)

            .RowHeight = dHeight

            For i = 1 To SH.Pictures.Count

                Set oPic = SH.Pictures("Immagine " & i)

                With .Cells(i)

                    oPic.Top = .Top + 2

                    oPic.Left = .Left

                    oPic.Placement = 2

                End With

            Next i

            .RowHeight = .RowHeight + 4

        End With

        For j = LRow - 1 To 2 Step -3

            .Cells(j).Copy Destination:=.Cells(j - 1, 2)

            .Cells(j).Resize(2).Clear

        Next j

    End With

    With SH.Columns("B:C")

        .EntireColumn.AutoFit

        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

    End With

XIT:

    Application.ScreenUpdating = True

End Sub

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

Eseguendo il codice, ottengo:

Potresti scaricare il mio file di prova mfrisco20180329.xlsm

NB:

Prima di eseguire il codice, ho inserito il testo Scrivi nella cella A24 perché vi mancava e questo avrebbe causato problemi con il codice.

===

Regards,

Norman

Answer 3

Ciao mfrisco0,

Perfetto, ottengo stesso risultato.

Grazie

Mi fa piacere che tu abbia risolto il problema e ti ringrazio per il cortese riscontro.

Per chiudere questo thread, vorrei chiederti gentilmente di contrassegnare la mia risposta come Risposta. In questo modo, tu aiuterai anche coloro che potessero cercare soluzioni ai problemi simili negli archivi della Community.

===

Regards,

Norman

Answer 4

Ciao mfrisco0,

con copia e incolla da internet ottengo (il file è allegato in fondo)

ho selezionato le righe dispari > altezza riga 1,8 e ottengo

manualmente seleziono con tasto dx (per evitare che apra il browser: a proposito uso Chrome) il nome A2 taglia e incolla in B1 e …

infine seleziono le righe pari e le cancello.

Questo è il risultato che vorrei ottenere.

Attenzione voglio mantenere il collegamento ipertestuale

Qui ho caricato il file di prova

https://1drv.ms/x/s!Atay-0SPRs4igQn9KkWldWu87Q0x

Prova qualcosa del genere;

In un modulo standard, incolla il seguente codice

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, RngTemp As Range

    Dim oPic As Picture

    Dim i As Long, LRow As Long

    Dim dHeight As Double, dLeft As Double, dTop As Double

    Const sFoglio As String = "Foglio1"        '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    Application.ScreenUpdating = False

    With SH

        dHeight = .Pictures("Immagine 1").Height

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

        Set Rng = .Range("A1:A" & LRow)

        On Error Resume Next

        Set RngTemp = Rng.SpecialCells(xlCellTypeBlanks)

        On Error GoTo 0

        If Not RngTemp Is Nothing Then

            RngTemp.Delete Shift:=xlUp

        End If

        .Columns(1).Insert

        .Columns(1).ColumnWidth = 6

        LRow = .Cells(Rows.Count, "B").End(xlUp).Row

        Set Rng = .Range("B1:B" & LRow)

    End With

    With Rng

        .EntireColumn.ColumnWidth = 30

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlCenter

        .IndentLevel = 1

        With .Offset(, -1)

            .RowHeight = dHeight

            For i = 1 To LRow

                Set oPic = SH.Pictures("Immagine " & i)

                With .Cells(i)

                    oPic.Top = .Top + 2

                    oPic.Left = .Left

                    oPic.Placement = 2

                End With

            Next i

            .RowHeight = .RowHeight + 4

        End With

    End With

XIT:

    Application.ScreenUpdating = True

End Sub

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

• Fai clic su Visualizza | Macro | Visualizza macro
• Nell'elenco in Nome macro seleziona Tester
• Faiclic su Esegui

Eseguendo questo codice con il file caricato da te, io ottengo i seguenti risultati:

                      ![](https://learn-attachment.microsoft.com/api/attachments/35f0b6f7-eb0c-41a8-a48f-fbdb974adb60?platform=QnA"https://learn-attachment.microsoft.com/api/attachments/eca7d23a-d22a-4974-bed5-b40fc962ce30?platform=QnA" rel="ugc nofollow">

Answer 5

Ciao mfrisco0,

ho un foglio in cui in colonna A nella cella dispari (A(2n-1) per n=1....) ho una foto e in quella pari (A2n) il nome e cognome.

Vorrei spostare nome e cognome nella colonna B quindi a fianco della foto (B(2n-1)) e cancellare le righe pari.

Spero di essere stato chiaro.

PS - premetto che il tutto è stato copiato da internet ed era già strutturato come vorrei, ma non so come mai, il nome e cognome è slittato sotto la foto.

Poichè le foto non si trovono dentro una cella ma invece sono oggetti che flottono sopra le celle, prova il seguente semplice procedimento:

• Seleziona l'intero intervallo di interesse della colonna A

                    ![](https://learn-attachment.microsoft.com/api/attachments/187d54b6-9dfb-410e-9c33-ac7e4606169e?platform=QnA"https://learn-attachment.microsoft.com/api/attachments/3c0d8556-8f0a-4866-a916-dd58c88bc56f?platform=QnA" rel="ugc nofollow">

• Riseleziona l'intervallo di interesse della colonna A
• F5 | Speciale | Costanti
• OK

         

• Fai clic dx
• Cancella | Intiera riga

           

• OK

Voilà!

PS - premetto che il tutto è stato copiato da internet ed era già strutturato come vorrei, ma non so come mai, il nome e cognome è slittato sotto la foto.

Avrei potuto adottare qualche accorgimento per evitare il lavoro di cui sopra?

Senza conoscenza di quello che hai trovato sull'internet, non saprei!

===

Regards,

Norman