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

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
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
Code to stack by row first rather than by column?
Replies
1
Views
668
MeghanES
M
R
  • Solved
Copy Area To Rows Using VBA
Replies
9
Views
494
Peter_SSs
Peter_SSs
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
336
Agnarr
Agnarr
duteberta
  • Question
How do I get macro to run in just one newly created cell in a new table row?
Replies
9
Views
131
StephenCrump
S
R
  • Solved
How do I extract the data label of a trendline in VBA?
2
Replies
14
Views
854
RockandGrohl
R

Forum statistics

Threads
1,214,599
Messages
6,120,447
Members
448,966
Latest member
DannyC96

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