CODEWITHSUNDEEP
vbaexcel
Dozens
Dozens

Reputation: 145

Stop erasing the content in the column not mentioned in the code

Hi I would like to create the code, where I could copy the values in a certain array and paste only the values of that array to the column in front. The arrays to be copied are in multiple arrays and should be copied and pasted to a column in front but only if there are numerical values in column A.

I have already got a very good answer for that from paul bica, where the code first Clears the data from the row before pasting it. However I have encountered the problem, it turns out that the code erases any content that is in column B:B, i.e. the column that should not be touched by the code anyhow.

To visualize it: This is how the arrays with values (in yellow) look before the copy: enter image description here

Outcome: enter image description here

Here is the code that I got from paul. It works almost 100% correct except that it clears the content in column B:B:

Option Explicit

Public Sub MoveRowsLeft()

    Const COL_NUMERIC = 1
    Const ROW_START = 4
    Const COL_START = 4

    Dim ws As Worksheet, lr As Long, lc As Long
    Dim nCol As Range, itm As Range, r As Long, arr As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1")

    lr = ws.Cells(ws.Rows.Count, COL_NUMERIC).End(xlUp).Row

    If lr > ROW_START Then
        Application.ScreenUpdating = False
        Set nCol = ws.Range(ws.Cells(ROW_START, COL_NUMERIC), ws.Cells(lr, COL_NUMERIC))
        For Each itm In nCol
            If Not IsError(itm) Then
                If IsNumeric(itm) And Len(itm.Value2) > 0 Then
                    r = itm.Row
                    lc = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
                    If lc > COL_NUMERIC Then
                        arr = ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc))
                        ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)).ClearContents
                        ws.Range(ws.Cells(r, COL_START - 1), ws.Cells(r, lc - 1)) = arr
                    End If
                End If
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub

Anybody who knows how to inhibit that erasing in column B:B?

Upvotes: 0

Views: 31

Answers (1)

paul bica
paul bica

Reputation: 10715

Previous answer does clear the content, but for col C (used by constant COL_START - 1)

Here is the fix

Option Explicit

Public Sub MoveRowsLeft()
    Const COL_NUMERIC = 1
    Const ROW_START = 4
    Const COL_START = 3
    Dim ws As Worksheet, lr As Long, lc As Long, i As Long
    Dim nCol As Range, itm As Range, r As Long, arr As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, COL_NUMERIC).End(xlUp).Row
    If lr > ROW_START Then
        Application.ScreenUpdating = False
        Set nCol = ws.Range(ws.Cells(ROW_START, COL_NUMERIC), ws.Cells(lr, COL_NUMERIC))
        For Each itm In nCol
            If Not IsError(itm) Then
                If IsNumeric(itm) And Len(itm.Value2) > 0 Then
                    r = itm.Row
                    lc = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
                    If lc > COL_START Then
                        arr = ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc))
                        ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)).ClearContents
                        For i = IIf(Len(arr(1, 2)) > 0, 2, 3) To UBound(arr, 2)
                            arr(1, i - 1) = arr(1, i)
                        Next
                        arr(1, i - 1) = vbNullString
                        ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)) = arr
                    End If
                End If
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub

Before

Before

After

After

(Let me know if you nee to keep all values in col C)

Upvotes: 1

Related Questions