Help with VBA modification

[Yamasaki450]

Hello.

I need some help to modify this VBA... Right now this VBA only works in "Sheet1". I would like it to work in all 8 sheets in my workbook at once... So in "Sheet1, Sheet2, Sheet3, Sheet4, Sheet5, Sheet6, Sheet7, Sheet8"

Is this possible?

Here is VBA i use

Option Explicit
Sub Delete_White_Cells_And_Shift_Up()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change sheet name to suit ***
    Dim r As Range
    Set r = ws.Range("L1627:VQX1627").CurrentRegion
    
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long
    LRow = r.Rows.Count
    LCol = r.Columns.Count
    k = 1
    For j = 1 To LCol
        For i = 1 To LRow
            If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 255, 255) Then
                b(k, j) = a(i, j)
                k = k + 1
            End If
        Next i
        k = 1
    Next j
    ws.Range("L1627:VQX1627").Resize(LRow, LCol).Value = b
    MsgBox Timer - t
End Sub

 

[jolivanes]

Your normal approach would be

For each ws In thisWorkbook.Worksheets

    '-----> do all your stuff here

Next ws

 

[rlv01]

Assuming your sheet names are "Sheet1" to "Sheet8" as you say, then perhaps

Sub Delete_White_Cells_And_Shift_Up()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Dim r As Range
    Dim a, b
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long, Indx As Long

    For Indx = 1 To 8
        Set ws = Worksheets("Sheet" & Indx)                 '<-- *** Change sheet name to suit ***
        Set r = ws.Range("L1627:VQX1627").CurrentRegion

        a = r

        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))

        LRow = r.Rows.Count
        LCol = r.Columns.Count
        k = 1
        For j = 1 To LCol
            For i = 1 To LRow
                If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 255, 255) Then
                    b(k, j) = a(i, j)
                    k = k + 1
                End If
            Next i
            k = 1
        Next j
        ws.Range("L1627:VQX1627").Resize(LRow, LCol).Value = b
        b = Nothing
    Next Indx
    MsgBox Timer - t
End Sub

 

[Yamasaki450]

Assuming your sheet names are "Sheet1" to "Sheet8" as you say, then perhaps

Sub Delete_White_Cells_And_Shift_Up()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    Dim r As Range
    Dim a, b
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long, Indx As Long

    For Indx = 1 To 8
        Set ws = Worksheets("Sheet" & Indx)                 '<-- *** Change sheet name to suit ***
        Set r = ws.Range("L1627:VQX1627").CurrentRegion

        a = r

        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))

        LRow = r.Rows.Count
        LCol = r.Columns.Count
        k = 1
        For j = 1 To LCol
            For i = 1 To LRow
                If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 255, 255) Then
                    b(k, j) = a(i, j)
                    k = k + 1
                End If
            Next i
            k = 1
        Next j
        ws.Range("L1627:VQX1627").Resize(LRow, LCol).Value = b
        b = Nothing
    Next Indx
    MsgBox Timer - t
End Sub

Yes my sheets are named Sheet1 to Sheet8 but it doesnt work. I get this error on screenshot.

 

[rlv01]

At which line of code?

(and on which worksheet, 1 to 8)

 

[Yamasaki450]

Dont know which line. It finishes Sheet1 then pops up this error.

 

[rlv01]

Dont know which line. It finishes Sheet1 then pops up this error.

All you have to do to find the line is press the "Debug" button on that message

 

[rlv01]

Try changing this line

b = Nothing

to this

Set b = Nothing

 

[Burrgogi]

Seems like the code that @jolivanes gave you is the most straight forward and simple answer. Have you tried it?

Option Explicit
Sub Delete_White_Cells_And_Shift_Up()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    For each ws In thisWorkbook.Worksheets
    Dim r As Range
    Set r = ws.Range("L1627:VQX1627").CurrentRegion
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long
    LRow = r.Rows.Count
    LCol = r.Columns.Count
    k = 1
    For j = 1 To LCol
        For i = 1 To LRow
            If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 255, 255) Then
                b(k, j) = a(i, j)
                k = k + 1
            End If
        Next i
        k = 1
    Next j
    ws.Range("L1627:VQX1627").Resize(LRow, LCol).Value = b
    Next ws
    MsgBox Timer - t
End Sub

 

[Yamasaki450]

All you have to do to find the line is press the "Debug" button on that message

I didnt know that sorry...

Try changing this line

b = Nothing

to this

Set b = Nothing

It works great now after this fix thanks.

Seems like the code that @jolivanes gave you is the most straight forward and simple answer. Have you tried it?

Option Explicit
Sub Delete_White_Cells_And_Shift_Up()
    Dim t As Double: t = Timer
    Dim ws As Worksheet
    For each ws In thisWorkbook.Worksheets
    Dim r As Range
    Set r = ws.Range("L1627:VQX1627").CurrentRegion
    Dim a, b
    a = r
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    Dim i As Long, j As Long, k As Long, LRow As Long, LCol As Long
    LRow = r.Rows.Count
    LCol = r.Columns.Count
    k = 1
    For j = 1 To LCol
        For i = 1 To LRow
            If r.Cells(i, j).DisplayFormat.Interior.Color <> RGB(255, 255, 255) Then
                b(k, j) = a(i, j)
                k = k + 1
            End If
        Next i
        k = 1
    Next j
    ws.Range("L1627:VQX1627").Resize(LRow, LCol).Value = b
    Next ws
    MsgBox Timer - t
End Sub

This also works i just didnt know where to put this line exactly.

Thanks for your help guys you are great...