How do I get this code to skip blank cells?

M

MeghanES

New Member
Joined
Aug 24, 2022
Messages
7
Office Version
  1. 365
Platform
  1. Windows
I'm self taught on excel and this is my first tiem using a macro on a spreadsheet but desperately need it to work for a task I'm doing at work. Could anyone tell me what to add to this code to make it skip blank cells? And where to add it if possible!

Here's the code:
Option Explicit

Sub Stack_cols()

On Error GoTo Stack_cols_Error

Dim lNoofRows As Long, lNoofCols As Long
Dim lLoopCounter As Long, lCountRows As Long
Dim sNewShtName As String
Dim shtOrg As Worksheet, shtNew As Worksheet

'Turn off the screen update to make macro run faster
Application.ScreenUpdating = False
'Ask for a new sheet name, if not provided use newsht
sNewShtName = InputBox("Enter the new worksheet name", "Enter name", "newsht")
'Set a sheet variable for the sheet where the data resides
Set shtOrg = ActiveSheet
'Add a new worksheet, rename it and set it to a variable
If Not SheetExists(sNewShtName) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
Set shtNew = Worksheets(sNewShtName)
Else
MsgBox "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
Exit Sub
End If

With shtOrg
'Get the last column number
'Replace .Range("IV1") with .Range("XFD1") for Excel 2007
lNoofCols = .Range("IV1").End(xlToLeft).Column
'Start a loop to copy and paste data from the first column to the last column
For lLoopCounter = 1 To lNoofCols
'Count the number of rows in the looping column
'Replace .Cells(65536, lLoopCounter) with .Cells(1048576, lLoopCounter) for Excel 2007
lNoofRows = .Cells(65536, lLoopCounter).End(xlUp).Row
.Range(.Cells(1, lLoopCounter), .Cells(lNoofRows, lLoopCounter)).Copy Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + lNoofRows, 1))
'count the number of rows in the new worksheet
lCountRows = lCountRows + lNoofRows
Next lLoopCounter
End With

On Error GoTo 0
SmoothExit_Stack_cols:
Application.ScreenUpdating = True
Exit Sub

Stack_cols_Error:
' if this gives you an error, make sure that there an ampersand (&) sign, rather than the &amp literal string. the code formatting is an issue
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub:Stack_cols"
Resume SmoothExit_Stack_cols
End Sub
'Check if a worksheet exists or not
Public Function SheetExists(sShtName As String) As Boolean
On Error Resume Next

Dim wsSheet As Worksheet, bResult As Boolean
bResult = False
Set wsSheet = Sheets(sShtName)

On Error GoTo 0
If Not wsSheet Is Nothing Then
bResult = True
End If
SheetExists = bResult
End Function

Thanks in advance!
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
Hi There

Is there any other data that needs to be kept? If not then maybe try deleting the empty rows after columns have been stacked? Can try code below: (use on sample data):

VBA Code: 
Option Explicit
Sub Stack_cols()
    On Error GoTo Stack_cols_Error
    Dim lNoofRows   As Long, lNoofCols As Long
    Dim lLoopCounter As Long, lCountRows As Long
    Dim sNewShtName As String
    Dim shtOrg      As Worksheet, shtNew As Worksheet
    'Turn off the screen update to make macro run faster
    Application.ScreenUpdating = False
    'Ask for a new sheet name, if not provided use newsht
    sNewShtName = InputBox("Enter the New worksheet name", "Enter name", "newsht")
    'Set a sheet variable for the sheet where the data resides
    Set shtOrg = ActiveSheet
    'Add a new worksheet, rename it and set it to a variable
    If Not SheetExists(sNewShtName) Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
        Set shtNew = Worksheets(sNewShtName)
    Else
        MsgBox "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
        Exit Sub
    End If
    With shtOrg
        'Get the last column number
        'Replace .Range("IV1") with .Range("XFD1") for Excel 2007
        lNoofCols = .Range("IV1").End(xlToLeft).Column
        'Start a loop to copy and paste data from the first column to the last column
        For lLoopCounter = 1 To lNoofCols
            'Count the number of rows in the looping column
            'Replace .Cells(65536, lLoopCounter) with .Cells(1048576, lLoopCounter) for Excel 2007
            lNoofRows = .Cells(65536, lLoopCounter).End(xlUp).Row
            .Range(.Cells(1, lLoopCounter), .Cells(lNoofRows, lLoopCounter)).Copy Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + lNoofRows, 1))
            'count the number of rows in the new worksheet
            lCountRows = lCountRows + lNoofRows
        Next lLoopCounter
    End With
    ' Deletes empty rows on active sheet, Added by Jimmypop 25/08/2022 -- If needed to remove just delete text from Dim to first Next
    Dim rRange      As Range, rowsCount As Long, i As Long
    Set rRange = ActiveSheet.Range("A1:B1000")
    rowsCount = rRange.Rows.Count
    For i = rowsCount To 1 Step -1
        If WorksheetFunction.CountA(rRange.Rows(i)) = 0 Then
            rRange.Rows(i).Delete
        End If
    Next
    On Error GoTo 0
SmoothExit_Stack_cols:
    Application.ScreenUpdating = True
    Exit Sub
Stack_cols_Error:
    ' if this gives you an error, make sure that there an ampersand (&) sign, rather than the &amp literal string. the code formatting is an issue
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub:Stack_cols"
    Resume SmoothExit_Stack_cols
End Sub
'Check if a worksheet exists or not
Public Function SheetExists(sShtName As String) As Boolean
    On Error Resume Next
    Dim wsSheet     As Worksheet, bResult As Boolean
    bResult = False
    Set wsSheet = Sheets(sShtName)
    On Error GoTo 0
    If Not wsSheet Is Nothing Then
        bResult = True
    End If
    SheetExists = bResult
End Function
 
Upvote 0
Hi
welcome to forum
not fully tested but see if this reworking of your code does what you want

VBA Code: 
Sub Stack_cols()
   
    Dim LastRow     As Long, LastColumn As Long
    Dim Col         As Long, lCountRows As Long
    Dim sNewShtName As String
    Dim shtOrg      As Worksheet, shtNew As Worksheet
   
    On Error GoTo Stack_cols_Error:
   
    Do
        SendKeys "{END}"
        'Ask for a new sheet name
        sNewShtName = InputBox("Enter the New worksheet name", "Enter name", "newsht")
        'cancel pressed
        If StrPtr(sNewShtName) = 0 Then Exit Sub
       
        If Len(sNewShtName) > 0 Then
            'check if sheet exists
            If Not Evaluate("ISREF('" & sNewShtName & "'!A1)") Then
                'all ok
                Exit Do
            Else
                'inform user & try again
                MsgBox sNewShtName & Chr(10) & "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
            End If
        End If
    Loop
   
    'Set a sheet variable for the sheet where the data resides
    Set shtOrg = ActiveSheet
   
    'Turn off the screen update to make macro run faster
    Application.ScreenUpdating = False
    'Add a new worksheet, rename it and set it to a variable
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
    Set shtNew = Worksheets(sNewShtName)
   
    With shtOrg
        'Get the last column number in row 1
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'Start a loop to copy and paste data from the first column to the last column
        For Col = 1 To LastColumn
            'Count the number of rows in the looping column
            LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row
            'copy only cells with constant values
            .Range(.Cells(1, Col), .Cells(LastRow, Col)).SpecialCells(xlCellTypeConstants).Copy _
            Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + LastRow, 1))
            'count of the number of non blank rows in column
            lCountRows = lCountRows + Application.CountA(.Columns(Col))
        Next Col
    End With
   
Stack_cols_Error:
    'report errors
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
   
End Sub

You will note that I have incorporated the duplicated sheet name test within the main code using a common line of code as negates need for separate function.
In addition, I also have included code to manage the cancel button press.

Hope Helpful

Dave
 
Upvote 0
Solution
Jimmypop said:
Hi There

Is there any other data that needs to be kept? If not then maybe try deleting the empty rows after columns have been stacked? Can try code below: (use on sample data):

VBA Code: 
Option Explicit
Sub Stack_cols()
    On Error GoTo Stack_cols_Error
    Dim lNoofRows   As Long, lNoofCols As Long
    Dim lLoopCounter As Long, lCountRows As Long
    Dim sNewShtName As String
    Dim shtOrg      As Worksheet, shtNew As Worksheet
    'Turn off the screen update to make macro run faster
    Application.ScreenUpdating = False
    'Ask for a new sheet name, if not provided use newsht
    sNewShtName = InputBox("Enter the New worksheet name", "Enter name", "newsht")
    'Set a sheet variable for the sheet where the data resides
    Set shtOrg = ActiveSheet
    'Add a new worksheet, rename it and set it to a variable
    If Not SheetExists(sNewShtName) Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
        Set shtNew = Worksheets(sNewShtName)
    Else
        MsgBox "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
        Exit Sub
    End If
    With shtOrg
        'Get the last column number
        'Replace .Range("IV1") with .Range("XFD1") for Excel 2007
        lNoofCols = .Range("IV1").End(xlToLeft).Column
        'Start a loop to copy and paste data from the first column to the last column
        For lLoopCounter = 1 To lNoofCols
            'Count the number of rows in the looping column
            'Replace .Cells(65536, lLoopCounter) with .Cells(1048576, lLoopCounter) for Excel 2007
            lNoofRows = .Cells(65536, lLoopCounter).End(xlUp).Row
            .Range(.Cells(1, lLoopCounter), .Cells(lNoofRows, lLoopCounter)).Copy Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + lNoofRows, 1))
            'count the number of rows in the new worksheet
            lCountRows = lCountRows + lNoofRows
        Next lLoopCounter
    End With
    ' Deletes empty rows on active sheet, Added by Jimmypop 25/08/2022 -- If needed to remove just delete text from Dim to first Next
    Dim rRange      As Range, rowsCount As Long, i As Long
    Set rRange = ActiveSheet.Range("A1:B1000")
    rowsCount = rRange.Rows.Count
    For i = rowsCount To 1 Step -1
        If WorksheetFunction.CountA(rRange.Rows(i)) = 0 Then
            rRange.Rows(i).Delete
        End If
    Next
    On Error GoTo 0
SmoothExit_Stack_cols:
    Application.ScreenUpdating = True
    Exit Sub
Stack_cols_Error:
    ' if this gives you an error, make sure that there an ampersand (&) sign, rather than the &amp literal string. the code formatting is an issue
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub:Stack_cols"
    Resume SmoothExit_Stack_cols
End Sub
'Check if a worksheet exists or not
Public Function SheetExists(sShtName As String) As Boolean
    On Error Resume Next
    Dim wsSheet     As Worksheet, bResult As Boolean
    bResult = False
    Set wsSheet = Sheets(sShtName)
    On Error GoTo 0
    If Not wsSheet Is Nothing Then
        bResult = True
    End If
    SheetExists = bResult
End Function
Click to expand...
Thank you so much, you guys are quick!
 
Upvote 0
dmt32 said:
Hi
welcome to forum
not fully tested but see if this reworking of your code does what you want

VBA Code: 
Sub Stack_cols()
  
    Dim LastRow     As Long, LastColumn As Long
    Dim Col         As Long, lCountRows As Long
    Dim sNewShtName As String
    Dim shtOrg      As Worksheet, shtNew As Worksheet
  
    On Error GoTo Stack_cols_Error:
  
    Do
        SendKeys "{END}"
        'Ask for a new sheet name
        sNewShtName = InputBox("Enter the New worksheet name", "Enter name", "newsht")
        'cancel pressed
        If StrPtr(sNewShtName) = 0 Then Exit Sub
      
        If Len(sNewShtName) > 0 Then
            'check if sheet exists
            If Not Evaluate("ISREF('" & sNewShtName & "'!A1)") Then
                'all ok
                Exit Do
            Else
                'inform user & try again
                MsgBox sNewShtName & Chr(10) & "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
            End If
        End If
    Loop
  
    'Set a sheet variable for the sheet where the data resides
    Set shtOrg = ActiveSheet
  
    'Turn off the screen update to make macro run faster
    Application.ScreenUpdating = False
    'Add a new worksheet, rename it and set it to a variable
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
    Set shtNew = Worksheets(sNewShtName)
  
    With shtOrg
        'Get the last column number in row 1
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'Start a loop to copy and paste data from the first column to the last column
        For Col = 1 To LastColumn
            'Count the number of rows in the looping column
            LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row
            'copy only cells with constant values
            .Range(.Cells(1, Col), .Cells(LastRow, Col)).SpecialCells(xlCellTypeConstants).Copy _
            Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + LastRow, 1))
            'count of the number of non blank rows in column
            lCountRows = lCountRows + Application.CountA(.Columns(Col))
        Next Col
    End With
  
Stack_cols_Error:
    'report errors
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
  
End Sub

You will note that I have incorporated the duplicated sheet name test within the main code using a common line of code as negates need for separate function.
In addition, I also have included code to manage the cancel button press.

Hope Helpful

Dave
Click to expand...
Thank you, Dave that's worked perfectly! And thank you for the welcome :) Hope to be as speedy as you lot soon!
 
Upvote 0
Most welcome - glad we could help & appreciate the feedback

Dave
 
Upvote 0
dmt32 said:
Most welcome - glad we could help & appreciate the feedback

Dave
Click to expand...
Hi Dave, me again! I'm using your code again for a different task but this time I need the cells in a row to be stacked in order if that makes sense. Where the current code takes all of column A for example and stacks all of column B underneath it and so on, I need all the cells containg a value from A1 onwards to be stacked on top of eachother.

So it would look like:
A1
B1
C1
D1
A2
A3
B3
C3
A4
A5
A6
B6
C6
D7
E6...
etc.

Do you know how to do this? Any help is really appreciated :) Thank you
 
Upvote 0
Hi,
as its a new question should really started a new thread where will get more response - you can provide link to this thread if needed

Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Code to stack by row first rather than by column?
Replies
1
Views
915
MeghanES
M
B
  • Question Question
VBA Code to Send Mail to skip blank cells
Replies
1
Views
274
Micron
M
R
  • Question Question
Having Trouble getting this code in VBA to work. Attempting to download a list of PDFs
Replies
1
Views
125
6StringJazzer
6StringJazzer
R
  • Solved
Copy Area To Rows Using VBA
Replies
9
Views
619
Peter_SSs
Peter_SSs
B
  • Locked
  • Question Question
copy range of cells
Replies
1
Views
65
Joe4
Joe4

Forum statistics

Threads
1,223,884
Messages
6,175,174
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top