How to modify this code to only search visible rows and columns - excel

I have a userform that allows the user to select which rows and columns are relevant to the user to check. I am using this code, but it searches all rows and all columns and therefore doesn't delete the right rows. Could anyone suggest a solution to fixing this that will work for rows and columns? Thanks.
Dim RowToTest As Long
Dim MySheet As Worksheet
Dim ProjectedDate As Date
Dim ColToTest As Long
Dim TempKeep As Integer
TempKeep = 0
ProjectedDate = Date + 60
For Each MySheet In ThisWorkbook.Sheets
For RowToTest = MySheet.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For ColToTest = MySheet.Cells(2, Columns.Count).End(xlToLeft).Column To 15 Step -1
With MySheet.Cells(RowToTest, ColToTest)
If IsDate(MySheet.Cells(RowToTest, ColToTest).Value) Then
If .Value < ProjectedDate Then
TempKeep = 1
End If
End If
End With
Next ColToTest
If TempKeep = 0 Then
MySheet.Rows(RowToTest).EntireRow.Delete
End If
TempKeep = 0
Next RowToTest
Next

You can check if a cell is hidden through their .Rows and .Columns property like so:
If CelToCheck.Rows.Hidden or CelToCheck.Columns.Hidden Then
'Your code if hidden
Else
'Code if not hidden
End if
In your case CelToCheck would be
MySheet.Cells(RowToTest, ColToTest)
Alternatively you can set a range variable and loop through visible cells only with
For each CL in RangeVariable.SpecialCells(xlCellTypeVisible)
'Your code
Next CL

I was about to suggest the same as JvdV, using the .Hidden property. Can use it in your code something like this:
Dim RowToTest As Long
Dim MySheet As Worksheet
Dim ProjectedDate As Date
Dim ColToTest As Long
Dim TempKeep As Integer
TempKeep = 0
ProjectedDate = Date + 60
For Each MySheet In ThisWorkbook.Sheets
For RowToTest = MySheet.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For ColToTest = MySheet.Cells(2, Columns.Count).End(xlToLeft).Column To 15 Step -1
With MySheet.Cells(RowToTest, ColToTest)
If IsDate(MySheet.Cells(RowToTest, ColToTest).Value) Then
If .Value < ProjectedDate Then
TempKeep = 1
End If
End If
End With
Next ColToTest
If TempKeep = 0 and Not isHiddenRow(MySheet, RowToTest) Then
MySheet.Rows(RowToTest).EntireRow.Delete
End If
TempKeep = 0
Next RowToTest
Next
don't necessarily need to have a function to do so, but makes it easier for code reuse.
Function isHiddenRow(sht As Worksheet, rowNr As Long) As Boolean
On Error Resume Next
isHiddenRow = sht.Rows(rowNr).Hidden
End Function
Function isHiddenCol(sht As Worksheet, colNr As Long) As Boolean
On Error Resume Next
isHiddenCol = sht.Columns(colNr).Hidden
End Function
PS: depending how much data you have in your sheet, is not a very good idea to loop directly over the sheet generally. Consider using arrays if you have thousands of rows.
EDIT: added an alternative using an array to do the same thing.
Option Explicit
Sub delVisibleRows()
Dim MySheet As Worksheet
Dim ProjectedDate As Date: ProjectedDate = Date + 60
Dim R As Long, C As Long, lRow As Long, lCol As Long
Dim arrData As Variant
Dim strRange As String
For Each MySheet In ThisWorkbook.Sheets 'for each sheet
With MySheet
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'get last row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column 'get last column
arrData = .Range(.Cells(1, 1), .Cells(lRow, lCol)) 'allocate the data to an array
For R = 2 To lRow 'iterate through all rows starting at 2
For C = 15 To lCol 'iterate through all columns, starting at 15 - this could cause a problem if there are less than 15 columns
If IsDate(arrData(R, C)) And arrData(R, C) < ProjectedDate Then 'check if is date, and if is less than projected date
Exit For 'if it is, skip to next row
End If
If C = lCol Then 'If we got to last col without meeting the skip condition
strRange = strRange & R & ":" & R & "," 'build the string for the range to delete
End If
Next C
Next R
strRange = Left(strRange, Len(strRange) - 1) 'get rid of the last comma
.Range(strRange).SpecialCells(xlCellTypeVisible).EntireRow.Delete 'delete only the visible rows
End With
Next MySheet
End Sub

Related

VBA Paste below collapsed Group

I have a macro that copies rows from a Sheet named "Template" and pastes them onto the Active Sheet in the next blank row.
However this macro only works when the grouped cells on the Active Sheet are expanded.
If the grouped cells are collapsed, then the macro replaces a previous collapsed group.
I have done some reading and discovered that using a different method to calculate the last row i.e. the MergeArea property would work with collapsed groups but just sure how to apply it.
How could I achieve this with the current code?
This is my code:
Sub Paste_New_Product_from_Template()
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim LRow As Long, i As Long
Dim StartNumber As Long
Dim varString As String
'~~> This is your input sheet
Set copySheet = ThisWorkbook.Worksheets("Template")
'~~> Variable
varString = copySheet.Cells(2, 2).Value2
'~~> Change this to the relevant sheet
Set pasteSheet = ThisWorkbook.ActiveSheet
'~~> Initialize the start number
StartNumber = 1
With pasteSheet
'~~> Find the last cell to write to
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
LRow = 2
Else
LRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'~~> Find the previous number
For i = LRow To 1 Step -1
If .Cells(i, 2).Value2 = varString Then
StartNumber = .Cells(i, 6).Value2 + 1
Exit For
End If
Next i
End If
copySheet.Range("2:" & copySheet.Cells(Rows.Count, 1).End(xlUp).Row).Copy
.Rows(LRow).PasteSpecial Paste:=xlPasteAll
'~~> Set the start number
.Cells(LRow, 6).Value = StartNumber
'~~> Format the number
.Cells(LRow, 6).Value = "'" & Format(StartNumber, "000")
End With
End Sub
Here is the code that uses the MergeArea procedure:
Private Function RowIsEmpty(WSh As Worksheet, Row As Long, StartColumnNumber As Integer, EndColumnNuber As Integer) As Boolean
Dim j As Integer
RowIsEmpty = True
For j = StartColumnNumber To EndColumnNuber
If (WSh.Cells(WSh.Cells(Row, j).MergeArea.Row, WSh.Cells(Row, j).MergeArea.Column) <> "") Then
RowIsEmpty = False
Exit For 'One of columns isn't empty
End If
Next j
End Function
Private Function CalcLastRowNumber(WSh As Worksheet, StartColumnNumber As Integer, EndColumnNuber As Integer) As Long
Dim i As Long
Dim j As Integer
Dim Result As Long
Dim Found As Boolean
Result = 1
For i = 1 To Rows.Count
If RowIsEmpty(WSh, i, StartColumnNumber, EndColumnNuber) And _
RowIsEmpty(WSh, i + 1, StartColumnNumber, EndColumnNuber) And _
RowIsEmpty(WSh, i + 2, StartColumnNumber, EndColumnNuber) Then
'Stop searching
Exit For 'All Columns are empty for current row and for next 2 rows
End If
Result = i
Next i
CalcLastRowNumber = Result
End Function
Sub New_Reviss_Order()

Excel VBA, Check values from columns between sheets and delete duplicate

I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub

VBA. Deleting multiple cells in a row if one cell is blank

I have multiple columns in an excel sheet...say A1:D10.
I want to find any blank cells in column C, delete that cell as well as the A,B, and D cells of that same row, then shift up. But only in the range of A1:D10. I have other information in this excel sheet outside this range that I want to perserve in its original position. Therefore I can not use somthing like this:
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Nor can I get something like the following to work, because it only shifts the single column up, not all four columns.
Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
If there is no data in columns A to D below row 10 that you don't want to move up, then SpecialCells and Delete Shift Up can be used like this
Sub Demo1()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
Dim rng As Range, arr As Range
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
On Error Resume Next
Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
For Each arr In rng.Areas
arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
Next
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If there is data in columns A to D below row 10 that you don't want to move up, then you can use Cut and Paste, like this
Sub Demo()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
If IsEmpty(.Cells(LastRow, TestColumn)) Then
.Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
End If
For i = LastRow - 1 To FirstRow Step -1
If IsEmpty(.Cells(i, TestColumn)) Then
.Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Using Variant Array Method
Sub test2()
Dim rngDB As Range, vDB As Variant
Dim i As Integer, j As Integer, n As Integer
Dim k As Integer
Set rngDB = Range("a1:d10")
vDB = rngDB
n = UBound(vDB, 1)
For i = 1 To n
If IsEmpty(vDB(i, 3)) Then
For j = 1 To 4
If j <> 3 Then
vDB(i, j) = Empty
End If
Next j
End If
Next i
For j = 1 To 4
If j <> 3 Then
For i = 1 To n - 1
For k = i To n - 1
If vDB(k, j) = Empty Then
vDB(k, j) = vDB(k + 1, j)
vDB(k + 1, j) = Empty
End If
Next k
Next i
End If
Next j
rngDB = vDB
End Sub
The below will take care of your requirement by looking for an empty cell in column 3, and deleting the row and shifting up only in that row.
Sub deleteEmptyRow()
Dim i As Integer
For i = 1 To 10
If Cells(i, 3) = "" Then
Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
End If
Next i
End Sub

Excel - Fill with blocks of dates

I am looking to fill a spreadsheet with data repeating data, so 25 appointments for today, 25 appointments for tomorrow with the same name and so on for as far as possible.
Is the a simple way of filling the table where the date increases in blocks of 25?
Example of what i am trying to do
Try using this you might be able to achieve what you want ,any problems shout out
'to change the date to the next day
Public Function ExtraDay(strDate As String)
Dim tDay As Date
tDay = Format(DateAdd("d", 1, strDate), "dd/mm/yy")
ExtraDay = tDay
End Function
'gets the last used row
Function getThelastUsedRowAddress() As Integer
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Set ws = ActiveSheet
MsgBox ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
getThelastUsedRowAddress = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
End Function
'button command on the sheet
Private Sub CommandButton1_Click()
Dim n, t As Integer
Dim ns As String
n = getThelastUsedRowAddress()
t = n + n
ns = CStr(t)
Call getThelastUsedRow(CStr(n))
Call TheLoopRange(CStr(n) + 1, ns)
End Sub
'get the last used and paste after
Sub getThelastUsedRow(address As String)
'Get Last Row in Worksheet UsedRange
Dim LastRow As Range, ws As Worksheet
Dim numcopied As Integer
Dim numonpaper As Integer
Set ws = ActiveSheet
numcopied = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
numonpaper = numcopied + 1
ws.UsedRange.Copy 'Destination:=Wst.Cells(1, 1)
'paste
Sheets("Sheet1").Range("A" & numonpaper).PasteSpecial xlPasteValues
End Sub
'loop the pasted range and change date to the next day from date
Sub TheLoopRange(rangestart As String, rangeend As String)
'rangestart,rangeend
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("E" & rangestart & ":E" & rangeend)
For Each rCell In rRng.Cells
'MsgBox rCell.Value
rCell.Value = ExtraDay(rCell.Value)
Next rCell
End Sub
Lets as assume that:
We use Sheet1
Company column is column D
Date column is column I
Pease try:
Option Explicit
Sub Test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 2 To Lastrow
If i = 2 Then
.Cells(i, 9).Value = Date + 1
ElseIf i <> 2 And .Cells(i, 4).Value = 1 Then
.Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value + 1
Else: .Cells(i, 9).Value = .Cells(i, 9).Offset(-1, 0).Value
End If
Next i
End With
End Sub

Copy data from between two cell values, and paste copied data in new column in new worksheet using VBA (Excel)

I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub

Resources