need vba macro to delete cells except first and last row in each column

Question

I have a excel which has multiple rows and columns and range of column values differ for each row.

Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.

Tried the below script:

Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range

Set sh = ThisWorkbook.Sheets("Sheet1")

    Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))

    For Each ID In IDS

        Dim b As Integer
        Dim k As Integer

        k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
        b = k - 1

        range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
        Selection.ClearContents

    Next ID

End Sub

Answer 1

This is a little different approach but should help.

Also, it is generally not best to declare variables in a loop as you do with b & k just fyi

Sub test()

    Dim sh As Worksheet
    Dim row As Integer
    Dim lastCol As Integer

    Set sh = ThisWorkbook.Sheets("Sheet1")

    For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row

        lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column

        sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
        sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents

    Next

End Sub

Best of luck

Answer 2

I'd go as follows:

Sub test()
    Dim cell As Range

    With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
        For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
            With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
                If .Count > 2 Then ' if referenced range has more then 2 cells
                    cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
                    .Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
                End If
            End With
        Next
    End With
End Sub

Answer 3

You can use Range.Delete Method (Excel)

range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft