Shifting cells to the left without affect its own column

Question

COLS : NO |   | B | C |   | D
  01 : 1  |   | 8 | 3 |   | 2
  02 :    |   |   | 4 |   | 
  03 :    |   |   |   |   |
  04 : 2  |   | 5 | 2 |   | 6

How can I shift the values to the left and delete empty rows but remain the values in it's own column? Goal is:

COLS : NO | B | C | D
  01 : 1  | 8 | 3 | 2
  02 :    |   | 4 | 
  03 : 2  | 5 | 2 | 6
  04 :    |   |   |

Number 4 in C2 should remain in it's own column (It's an extra value for record number 1 at column C). What I get now is not what I want:

COLS : NO | B | C | D
  01 : 1  | 8 | 3 | 2
  02 : 4  |   |   | 
  03 : 2  | 5 | 2 | 6
  04 :    |   |   |

Answer 1

Try

Sub test2()
    Dim Ws As Worksheet
    Dim rngDB As Range, rng As Range
    Dim vDB As Variant, vR() As Variant
    Dim i As Long, r As Long
    Dim n As Long, c As Integer, j As Integer
    Dim k As Integer
    Dim vC(), vRow()

    Set Ws = ActiveSheet
    Set rngDB = Ws.UsedRange
    vDB = rngDB
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For i = 1 To r
        Set rng = rngDB.Rows(i)
        If Not WorksheetFunction.CountA(rng) = 0 Then
            n = n + 1
            ReDim Preserve vRow(1 To n)
            vRow(n) = i
        End If
    Next i
    For i = 1 To c
        Set rng = rngDB.Columns(i)
        If Not WorksheetFunction.CountA(rng) = 0 Then
            k = k + 1
            ReDim Preserve vC(1 To k)
            vC(k) = i
        End If
    Next i
    ReDim Preserve vR(1 To n, 1 To k)
    For i = 1 To n
        For j = 1 To k
            vR(i, j) = vDB(vRow(i), vC(j))
        Next j
    Next i

    Sheets.Add
    Range("a1").Resize(n, k) = vR
End Sub



Sub test()
    Dim Ws As Worksheet
    Dim rngDB As Range, rng As Range
    Dim vDB As Variant, vR() As Variant
    Dim i As Long, r As Long
    Dim n As Long, c As Integer, j As Integer
    Dim k As Integer

    Set Ws = ActiveSheet
    Set rngDB = Ws.UsedRange
    vDB = rngDB
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)
    ReDim vR(1 To r, 1 To c)
    For i = 1 To r
        Set rng = rngDB.Rows(i)
        If WorksheetFunction.CountA(rng) Then
            n = n + 1
            k = 0
            For j = 1 To c
                If vDB(i, j) <> "" Then
                    k = k + 1
                    vR(n, k) = vDB(i, j)
                End If
            Next j
        End If
    Next i
    'rngDB = vR  '<~~~  Use this to write on the same sheet.
    Sheets.Add
    Range("a1").Resize(r, c) = vR
End Sub

Before

After