I have to find the last column of a row in a sheet. I am able to find the last column in the sheet, but for a particular row, I need to find the last column which will vary for every sheet in the excel, and it will vary at every run. To find the last column, I have used the below code, with reference from the question Finding last column across multiple sheets in a function:
For Each ws In ThisWorkbook.Sheets
lc = ws.Cells.Find("*", SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Column
Debug.Print ws.Name, lc
MsgBox lc
Next ws
Updated:
Trying to use the below code, but its showing error code 91. Function is :
Function lastColumn(Optional sheetName As String, Optional
rowToCheck As Long = 1) As Long
Dim ws As Worksheet
If sheetName = vbNullString Then
Set ws = ActiveSheet
Else
Set ws = Worksheets(sheetName)
End If
lastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column
End Function
Calling it in the code as:
For Each ws In ThisWorkbook.Worksheets
i = ws.Columns(2).Find("Total").Row (error code as 91)
Debug.Print lastColumn(ws.Name, i)
Next ws
Sub Test()
For Each ws In ThisWorkbook.Sheets
lc = ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column
Debug.Print ws.Name, lc
MsgBox lc
Next ws
End Sub
Just replace i with the row number.
This is the function that I am using for lastColumn per specific row:
Function lastColumn(Optional sheetName As String, Optional rowToCheck As Long = 1) As Long
Dim ws As Worksheet
If sheetName = vbNullString Then
Set ws = ActiveSheet
Else
Set ws = Worksheets(sheetName)
End If
lastColumn = ws.Cells(rowToCheck, ws.Columns.Count).End(xlToLeft).Column
End Function
It takes optional arguments sheetName and rowToCheck. This is a way to run it for your case:
Public Sub TestMe()
Dim ws As Worksheet
Dim lc As Long
lc = 8
For Each ws In ThisWorkbook.Worksheets
Debug.Print lastColumn(ws.Name, lc)
Next ws
End Sub
Try this :
With Worksheets(set_sheet_name)
LastCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
End With
this will get you nr. of columns from the line "5", if you want another line just change the 5 with whatever line you need.
Related
I am a bit stuck and hoping to find some help. I have some experience in VBA but this particular problem exceeds my programming knowledge.
I have a sheet with 1000 - 1250 rows of data, and anywhere from 20 - 60 columns that can change monthly.
What I am hoping to do is look at each cell for an X, and when found it will create a new line on a separate tab. The line would contain the first cell in the row where the X was found and the column header from the column the X was found in.
I have been able to write some things that will find the X's in the sheet, create new items on another page and the like, but I can't get one script to do everything I need.
This is an example of the data structure:
Data
Expected result:
Output
Sorry for the links, I am too new to post photos.
Any help on how this can be achieved, documents, tips or the like would be super helpful and most appreciated. Thank you for looking!
Andrew
EDIT:
Some of the code I have put together:
Dim uSht As String
Dim wsExists As Boolean
Dim lRow As Long
Dim lcol As Long
Dim ws As Worksheet
Sub CopyData()
'Setup Sheetnames
uSht = "UPLOAD"
uTem = "TEMPLATE"
' Stop flicker
Application.ScreenUpdating = False
' Check for Upload Worksheet
WorksheetExists (uSht)
'MsgBox (wsExists)
If wsExists = False Then
' If it does not exist, create it
Call CreateSheet("UPLOAD")
End If
'Setup stuff
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets(uTem)
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(uSht)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox (lRow)
'MsgBox (lCol)
Range(Cells(lRow, lColumn)).Select
Application.ScreenUpdating = True
End Sub
Sub CreateSheet(wsName)
'Creates the uSht worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = uSht
End With
End Sub
Function WorksheetExists(wsName As String) As Boolean
'Check to see if uSht exists and return.
wsName = UCase(wsName)
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = wsName Then
wsExists = True
Exit For
End If
Next
WorksheetExists = wsExists
End Function
Using FindAll from here: Extracting specific cells from multiple Excel files and compile it into one Excel file
(but change LookAt:=xlPart to LookAt:=xlWhole)
Rough outline:
Dim col, c, dest As Range
Set dest = sheets("results").Range("A2")
Set col = FindAll(sheets("data").range("a1").currentregion, "X")
For each c in col
dest.resize(1,2).value = array(c.entirerow.cells(1).value, _
c.entirecolumn.cells(1).value)
set dest = dest.offset(1, 0)
next
You need a Find/FindNext loop that will locate all X values in the first worksheet. After a found cell is located, the cell's row and column can be used to identify the location and project.
Option Explicit
Sub Macro1()
Dim addr As String, loc As String, pro As String
Dim ws2 As Worksheet, fnd As Range
Set ws2 = Worksheets("sheet2")
With Worksheets("sheet1")
Set fnd = .Cells.Find(What:="x", after:=.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fnd Is Nothing Then
addr = fnd.Address(0, 0)
Do
loc = .Cells(fnd.Row, "A").Value
pro = .Cells(1, fnd.Column).Value
With ws2
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = loc
.Cells(.Rows.Count, "A").End(xlUp).Offset(0, 1) = pro
End With
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address(0, 0)
End If
End With
End Sub
I have multiple sheets in a particular workbook, and n each sheet there are Employee Numbers. The sheets have already been sorted in a way that Column A is always the Employee Number.
So what I need to do is loop through all the sheets and apply the RemoveDuplicates function to delete all duplicate Employee Numbers found in Column A.
Note - I am not trying to have the Employee Number appear on only one sheet; I am trying to have the Employee Number appear only once on each sheet.
I have it working for when I name a specific sheet, but cannot get it to work in a loop.
Test1:
Sub deleteDuplicate()
Dim ws As Worksheet
Dim wkbk1 As Workbook
Dim w As Long
Dim lRow As Long
Dim iCntr As Long
Set wkbk1 = Workbooks("3rd Party.xlsm")
wkbk1.Activate
For Each ws In ThisWorkbook.Worksheets
' Find last row in column A
lRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
For iCntr = lRow To 1 Step -1
ws.lRow.RemoveDuplicates Columns:=1, Header:=xlYes
Next iCntr
Next ws
End Sub
Test2:
Sub deleteDuplicate()
Dim ws As Worksheet
Dim wkbk1 As Workbook
Dim w As Long
Dim lRow As Long
Dim iCntr As Long
Set wkbk1 = Workbooks("3rd Party.xlsm")
wkbk1.Activate
With wkbk1
For w = 1 To .Worksheets.count
With Worksheets(w)
.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
End With
Next w
End With
End Sub
The issue in both tests
Set wkbk1 = Workbooks("3rd Party.xlsm") - it implies the code is not in ThisWorkbook, yet
Test 1 uses ThisWorkbook - explicitly (For Each ws In ThisWorkbook.Worksheets)
Test 2 uses ThisWorkbook - implicitly (With Worksheets(w))
For this to work the file "3rd Party.xlsm" must be open at the same time
Try the versions bellow, and if the code is not running in ThisWorkbook, update wb accordingly
(ThisWorkbook is the file where the VBA code is executed from)
.
Version 1 - determine last row and last column
Option Explicit
Public Sub DeleteDuplicates1()
Dim wb As Workbook, ws As Worksheet, lr As Long, lc As Long, ur As Range
On Error Resume Next 'Expected error: wb not found
Set wb = ThisWorkbook 'Workbooks("3rd Party.xlsm")
If Not wb Is Nothing Then
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set ur = ws.Range("A1", ws.Cells(lr, lc))
ur.RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next
Application.ScreenUpdating = True
End If
End Sub
.
Version 2 - UsedRange
Public Sub DeleteDuplicates2()
Dim wb As Workbook, ws As Worksheet
On Error Resume Next 'Expected error: wb not found
Set wb = ThisWorkbook 'Workbooks("3rd Party.xlsm")
If Not wb Is Nothing Then
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
ws.UsedRange.RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next
Application.ScreenUpdating = True
End If
End Sub
If nothing happens when you run either of these versions, the file "3rd Party.xlsm" doesn't exist.
Either it's not open currently, or the name is different - maybe "3rd Party.xlsx" (with an x)
.
If you still have errors for Version 2, .UsedRange may not be what you expect
Try cleaning extra rows and columns with this Sub
Public Sub RemoveEmptyRowsAndColumns()
Dim wb As Workbook, ws As Worksheet, lr As Long, lc As Long, er As Range, ec As Range
On Error Resume Next 'Expected error: wb not found
Set wb = ThisWorkbook 'Workbooks("3rd Party.xlsm")
If Not wb Is Nothing Then
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If lr > 1 And lc > 1 Then
Set er = ws.Range(ws.Cells(lr + 1, "A"), ws.Cells(ws.Rows.Count, "A"))
Set ec = ws.Range(ws.Cells(1, lc + 1), ws.Cells(1, ws.Columns.Count))
er.EntireRow.Delete 'Shift:=xlUp
ec.EntireColumn.Delete 'Shift:=xlToLeft
End If
Next
Application.ScreenUpdating = True
End If
End Sub
Newbie at vba here. I'm trying to apply a simple For Each loop (which nullifies cells < 0) to all worksheets in the workbook by nesting this inside another For Each loop.
When I try and run my code below I get an error and I'm not sure if it has anything to do with having worksheet as a variable within a Set statement.
Can't seem to figure this out/find a solution.
Thanks
Sub deleteNegativeValue()
Application.DisplayAlerts = False
Dim lastRow As Long
Dim ws As Worksheet
Dim cell As Range
Dim res As Range
For Each ws In Workbooks(1).Worksheets
Set res = ws.Range("1:1").Find("Value", lookat:=xlPart)
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range(ws.Cells(1, res.Column), ws.Cells(lastRow, res.Column))
If cell < 0 Then cell = ""
Next
Next
End Sub
Try this:
Sub deleteNegativeValue()
Dim lastRow As Long
Dim ws As Worksheet
Dim cell As Range
Dim res As Range
For Each ws In ThisWorkbook.Worksheets
Set res = ws.Range("1:1").Find("Value", lookat:=xlPart)
lastRow = ws.Range("A" & Rows.Count).End(xlUp).row
If Not res Is Nothing Then
For Each cell In ws.Range(ws.Cells(1, res.Column), ws.Cells(lastRow, res.Column))
If cell < 0 Then cell = ""
Next
Else
MsgBox "No Value found on Sheet " & ws.Name
End If
Next
End Sub
There needs to be a check on the Find method, to ensure that something was found
you could try this
Option Explicit
Sub deleteNegativeValue()
Dim ws As Worksheet
Dim res As Range
For Each ws In ThisWorkbook.Worksheets
Set res = Intersect(ws.Rows(1), ws.UsedRange).Find("value", LookAt:=xlPart)
If Not res Is Nothing Then
ws.Columns(res.Column).SpecialCells(xlCellTypeConstants, xlNumbers).Replace What:="-*", Replacement:="", SearchOrder:=xlByColumns, MatchCase:=False, LookAt:=xlWhole
Else
MsgBox "No Value found on Sheet " & ws.Name
End If
Next
End Sub
which should run faster since it doesn't iterate through every cell of each column and restrict the Find method range to the used one instead of the entire row.
the only warning is that the first row of all searched in sheets must not be empty...
Try the second for-each this way:
ws.Range(ws.Cells(1, res.Column), ws.Cells(lastRow, res.Column))
I have been a silent reader on here for a few months but have been struggling with this code for a week now, so thought i would see if anyone can help.
I have a worksheet where sheet 1 contains information for users to input data.
Column A ask a question, column C is where the user will type in an answer.
Row 4 asks how many configurations there will be. depending on what number they input depends on how many cells light up to the right ie if 1 then D4 goes yellow, if 2 then D4 and E4 go yellow (using conditional formatting)
The user will then enter the title into the highlighted cell (D4,E4 ,F4 etc)
I want to create a new sheet at the end of the sheet for each configuration.
then NAME the new sheet by the text entered in D4, E4 etc.
the code I have so far is:
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 3 To Lastcol
If DoesSheetExist(ActiveSheet.Cells(4 & i).Value) Then
Set tmpSht = ActiveSheet.Cells(4 & i).Value
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(ws)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
I put in "NEWSHEET" to see if even creates a new sheet, but it still fails. I just cant see where I am going wrong.
Any help /advise is welcomed.
EDIT .
I cant work out why though.
The last col will be H4 so lastcol would be "8" .
Then for i = 4 to 8 run the loop. there are descriptions in each of the cells in row 4 so i don't see why it would work for 2 instantness and then fail ?
I dont know if this would make it easier but I have the number of sheets i want to create in cell C4 so i could use this rather than looking up populated cells. so if C4 is 2 then I want to add 2 sheets named as the content of D4, E4. if C4 is 3 then I want to add 3 sheets names as content of D3,E3,F3. Am I making this harder than I need too ?
UPDATE
I figured out the copying over of info is affecting this loop. and amended the code to this.
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
.Rows(13).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
this is doing what i want it to do with a couple of small exceptions.
the Sheets are being named by the cells in D1 , then E13,F13,G13,H13 So i need to figure out where that info is coming from.
the final bit is that due to my conditional formatting in the First sheet, I am getting text on black backgrounds in the copy cells, but that is the very least of my worries !
UPDATE
Found the error -
sShtName = ActiveSheet.Cells(4, i).Value2
should be
sShtName = Worksheets(1).Cells(4, i).Value2
You are calling your cells incorrectly. Use (4, i) instead of (4 & i).
The way you were calling it concatenated it to 43, which resulted in you checking cell AQ1 (AQ being the 43rd column) for the sheet reference.
Edit: I just walked through it a bit and found a couple of other errors. You need to set the sheet name to sht in your 'exists' function, and I'm assuming you want to set tmpSht to a sheet, so you need to encase it in sheets(). Try this:
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
Instead of adding the new sheet and then setting the activesheet to the tmpsht you could use a shorter way (see below). And why did you set the ws if you don't use it....
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = .Cells(4, .Columns.Count).End(xlToLeft).Column
If (Lastcol < 4) Then
Exit Sub
End If
For i = 4 To Lastcol
If (DoesSheetExist(.Cells(4, i).Value2) = True) Then
Set tmpSht = Sheets(.Cells(4, i).Value)
Else
Set tmpSht = Sheets.Add After:=Sheets(Sheets.Count)
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then
DoesSheetExist = True
Else
DoesSheetExist = False
End If
End Function
This was my final code. There were a few tweaks, Firstly I added a formula in row 6 to shorten the name of row 4 to a 10 character name as I found the tab names were too long (hence the code for the naming refers to row 6. I also added some custom text to add into each sheet and some formatting
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer
Dim i As Integer
Dim j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column ' work with the template sheet
If Lastcol = 3 Then Exit Sub 'repeat these steps from the first config to the last
For i = 4 To Lastcol
sShtName = Worksheets(1).Cells(6, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName tmpSht.Name = sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1) ' Format the cell width in the new sheet
.Rows(13).Copy tmpSht.Rows(4)
tmpSht.Range("A1").Value = Worksheets(1).Cells(4, i).Value2
Range("A1").ColumnWidth = 30
Range("B1").ColumnWidth = 0
Range("C1").ColumnWidth = 30
Range("D1:K1").ColumnWidth = 10
Range("D4:J4").Font.Color = vbWhite ' format the colour of the text in the new sheet
Range("C1") = " " ' Negate info in cell C1
With Range("A1:M5") ' add borders
'Clear existing
.Borders.LineStyle = xlNone
'Apply new borders
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With Range("A1:C4") ' set colours for the new sheet
.Font.Color = vbBlack
.Interior.Color = vbWhite
End With
Range("D4:J4").Font.Color = vbWhite ' set colour of the numbers to white to show on black background
Range("A5") = "Unit cost in " & Worksheets(1).Cells(17, 3).Value2
Range("A6") = "CUSTOM TEXT ONE."
Range("A7") = "NOTE if quantity " & Range("D4").Value2 + 5 & " is ordered then total cost will be your unit cost for " & Range("D4").Value2 & " multiplied by " & Range("D4").Value2 + 5 & " .This applies up to the quantity of " & Range("E4").Value2 - 1
Range("A8") = "CUSTOM TEXT 2"
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
I want to delete rows over multiple worksheets (only specific ones within the workbook) if a cell value is blank. Note, the rest of the fields in the row do contain data. So far I have the below however unsure how to specify the worksheets. Can anyone help?
Sub sbDelete_rows_if_cell_blank()
Dim lRow As Long
Dim iCntr As Long
lRow = 2000
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 1).Value = "" Then
Rows(iCntr).Delete
End If
Next
End Sub
Putting your code inside this loop will loop through all the worksheets in the Workbook that this code is inside and run your code in each.
Sub sbDelete_rows_if_cell_blank()
Dim lRow As Long
Dim iCntr As Long
Dim ws as Worksheet
For each ws in ThisWorkbook.Worksheets
' Find last row in column A
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For iCntr = lRow To 1 Step -1
If ws.name<>"Sheet1" and ws.name <> "Sheet2" then ' change this line to the sheet names you want to leave out.
If IsEmpty(ws.Cells(iCntr, 1)) Or Trim(ws.Cells(iCntr, 1).Value) = "" Then
ws.Rows(iCntr).Delete
End If
end if
Next iCntr
Next ws
End Sub
Updated with D_Bester's suggestion for if condition
Update 2: See Comments
This will do what I think you want to achieve
Sub Combine()
Dim nws, ws As Worksheet
Dim rng As Range
' Add New Sheet
On Error Resume Next
Set nws = ThisWorkbook.Sheets("Combined")
If nws Is Nothing Then
With ThisWorkbook.Sheets
Set nws = .Add(After:=Sheets(.Count))
nws.Name = "Combined"
End With
End If
On Error GoTo 0
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = nws.Name Then
With ws
Set rng = Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
rng.Copy Destination:=nws.Cells(nws.Cells(nws.Rows.Count, "A").End(xlUp).Row + 1, 1)
End With
End If
Next ws
End Sub
You can loop through the sheets, then use specialcells to delete the blanks.
Yoi can also set the loop so it doesn't delete the blanks in "Sheet1"(in this example)
Sub DeleteBlnkRows()
Dim sh As Worksheet
For Each sh In Sheets
If sh.Name <> "Sheet1" Then
sh.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
Next sh
End Sub