I am try to get a column number to change automatically, by -1, if the same number is entered in the same column again.
Basically I am sorting a list 1 to whatever and then auto sort and change everything below that new number to change by -1. I have the VBA to auto sort as I go but the change in number has me stumped.
Starting point:
If I change D9 to 5 I need it to move into that position (D6) and change D7:D11 by -1
I already have the VBA for the sorting:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("A:d")) Is Nothing Then
Range("D1").Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub
but really need help with the other.
What you are asking for will work if a cell in column D is changed to a value greater than its current value. It won't work if its changed to a value less than its current value.
Here's a solution that works for both
Note: this assumes column D starts out numbered sequentialy from 1 and sorted. If not, you'll get weird results.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TargetRow As Long, i As Long, lr As Long
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("d:d")) Is Nothing Then
On Error GoTo EH
TargetRow = Target.Row
Application.EnableEvents = False
lr = Me.Cells(Me.Rows.Count, 4).End(xlUp).Row
If Target.Value2 >= TargetRow Then
If Target.Value2 >= lr Then Target.Value2 = lr - 1
For i = TargetRow + 1 To Target.Value2 + 1
Me.Cells(i, 4).Value2 = Me.Cells(i, 4).Value2 - 1
Next
ElseIf Target.Value2 < TargetRow - 1 Then
If Target.Value2 <= 0 Then Target.Value2 = 1
For i = Target.Value2 + 1 To TargetRow - 1
Me.Cells(i, 4).Value2 = Me.Cells(i, 4).Value2 + 1
Next
End If
Me.Range("A1:D" & lr).Sort Key1:=Me.Range("D2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End If
EH:
Application.EnableEvents = True
End Sub
Related
I would like to delete the empty rows my ERP Quotation generates. I'm trying to go through the document (A1:Z50) and for each row where there is no data in the cells (A1-B1...Z1 = empty, A5-B5...Z5 = empty) I want to delete them.
I found this, but can't seem to configure it for me.
On Error Resume Next
Worksheet.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
How about
sub foo()
dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A1:Z50")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
Try this
Option Explicit
Sub Sample()
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Range("A" & i & ":" & "Z" & i)
Else
Set DelRange = Union(DelRange, Range("A" & i & ":" & "Z" & i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
IF you want to delete the entire row then use this code
Option Explicit
Sub Sample()
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Rows(i)
Else
Set DelRange = Union(DelRange, Rows(i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
I know I am late to the party, but here is some code I wrote/use to do the job.
Sub DeleteERows()
Sheets("Sheet1").Select
Range("a2:A15000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
for those who are intersted to remove "empty" and "blank" rows ( Ctrl + Shift + End going deep down of your worksheet ) .. here is my code.
It will find the last "real"row in each sheet and delete the remaining blank rows.
Function XLBlank()
For Each sh In ActiveWorkbook.Worksheets
sh.Activate
Cells(1, 1).Select
lRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Range("A" & lRow + 1, Range("A1").SpecialCells(xlCellTypeLastCell).Address).Select
On Error Resume Next
Selection.EntireRow.SpecialCells(xlBlanks).EntireRow.Delete
Cells(1, 1).Select
Next
ActiveWorkbook.Save
ActiveWorkbook.Worksheets(1).Activate
End Function
Open VBA ( ALT + F11 ), Insert -> Module,
Copy past my code and launch it with F5.
Et voila :D
I have another one for the case when you want to delete only rows which are complete empty, but not single empty cells. It also works outside of Excel e.g. on accessing Excel by Access-VBA or VB6.
Public Sub DeleteEmptyRows(Sheet As Excel.Worksheet)
Dim Row As Range
Dim Index As Long
Dim Count As Long
If Sheet Is Nothing Then Exit Sub
' We are iterating across a collection where we delete elements on the way.
' So its safe to iterate from the end to the beginning to avoid index confusion.
For Index = Sheet.UsedRange.Rows.Count To 1 Step -1
Set Row = Sheet.UsedRange.Rows(Index)
' This construct is necessary because SpecialCells(xlCellTypeBlanks)
' always throws runtime errors if it doesn't find any empty cell.
Count = 0
On Error Resume Next
Count = Row.SpecialCells(xlCellTypeBlanks).Count
On Error GoTo 0
If Count = Row.Cells.Count Then Row.Delete xlUp
Next
End Sub
To make Alex K's answer slightly more dynamic you could use the code below:
Sub DeleteBlankRows()
Dim wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngIdx As Long, _
lngColCounter As Long
Dim blnAllBlank As Boolean
Dim UserInputSheet As String
UserInputSheet = Application.InputBox("Enter the name of the sheet which you wish to remove empty rows from")
Set wks = Worksheets(UserInputSheet)
With wks
'Now that our sheet is defined, we'll find the last row and last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
'Since we need to delete rows, we start from the bottom and move up
For lngIdx = lngLastRow To 1 Step -1
'Start by setting a flag to immediately stop checking
'if a cell is NOT blank and initializing the column counter
blnAllBlank = True
lngColCounter = 2
'Check cells from left to right while the flag is True
'and the we are within the farthest-right column
While blnAllBlank And lngColCounter <= lngLastCol
'If the cell is NOT blank, trip the flag and exit the loop
If .Cells(lngIdx, lngColCounter) <> "" Then
blnAllBlank = False
Else
lngColCounter = lngColCounter + 1
End If
Wend
'Delete the row if the blnBlank variable is True
If blnAllBlank Then
.rows(lngIdx).delete
End If
Next lngIdx
End With
MsgBox "Blank rows have been deleted."
End Sub
This was sourced from this website and then slightly adapted to allow the user to choose which worksheet they want to empty rows removed from.
In order to have the On Error Resume function work you must declare the workbook and worksheet values as such
On Error Resume Next
ActiveWorkbook.Worksheets("Sheet Name").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
I had the same issue and this eliminated all the empty rows without the need to implement a For loop.
This worked great for me (you can adjust lastrow and lastcol as needed):
Sub delete_rows_blank2()
t = 1
lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Do Until t = lastrow
For j = 1 To lastcol
'This only checks the first column because the "Else" statement below will skip to the next row if the first column has content.
If Cells(t, j) = "" Then
j = j + 1
If j = lastcol Then
Rows(t).Delete
t = t + 1
End If
Else
'Note that doing this row skip, may prevent user from checking other columns for blanks.
t = t + 1
End If
Next
Loop
End Sub
Here is the quickest way to Delete all blank Rows ( based on one Columns )
Dim lstRow as integet, ws as worksheet
Set ws = ThisWorkbook.Sheets("NameOfSheet")
With ws
lstRow = .Cells(Rows.Count, "B").End(xlUp).Row ' Or Rows.Count "B", "C" or "A" depends
.Range("A1:E" & lstRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End with
I am trying to create a scoreboard using VBA in Excel. When users click on the button to enter (See image below), they will key in their names, id and numeric answer in a user form (So 3 text boxes for them to fill up).
After the user clicks submit in the userform, the value should be saved in Sheet 1 for collation (take note of the 4,000 in Cell D2, more on it later):
This is the code for the userform:
Private Sub CommandButton1_Click()
If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Then
If MsgBox("Your details are not complete! Do you want to continue?", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
End If
Worksheets("Sheet1").Select
'Worksheets("Sheet1").Range("A2").Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value
ActiveCell.Offset(1, 0).Select
Call resetform
End Sub
Sub resetform()
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
UserForm1.TextBox1.SetFocus
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsNumeric(TextBox3.Value) Then
MsgBox "Only numbers are allowed"
Cancel = True
End If
End Sub
By right, when users click on the submit answer command button, the values will be saved accordingly in Sheet1 with the code above.
However, my issue arises here now. I want to sort the values by absolute differences. I.e I want to compare all the numeric answers in Col C of Sheet1, to the target answer in Cell C3 of Sheet2.:
After calculating the absolute differences, I want to sort the rows according to the absolute differences in Ascending order. This is the code for the sorting:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For i = 1 To Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
calc = Sheet1.Cells(i + 1, "C").Value
test = Sheet2.Cells(3, 3).Value
Sheet1.Cells(i + 1, "D").Value = Abs(test - calc)
Application.EnableEvents = False
Range("A:D").Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Application.EnableEvents = True
Next i
End If
End Sub
However, when I clear my fields in Sheet1, the 4,000 in Cell D2 appears. (I'm guessing it has to do with the 4,000 in the target answer minusing 0 since the fields are blank.) If I have new entries, and the difference is very huge, the sheet becomes messed up and looks like this:
When I key in another number with a huge absolute difference, the 4,000 is repeated and the previous largest absolute difference is replaced with the new largest absolute difference value. Does anyone know why?
For #Mikku this is the latest error!:
I think this will solve your problem. Looks like you are selecting any other cell before running the Userform, which in turn is the reason for those 2 blank rows. Try the Below and tell me if it's still happening.
Change:
Worksheets("Sheet1").Select
'Worksheets("Sheet1").Range("A2").Select
ActiveCell = TextBox1.Value
ActiveCell.Offset(0, 1) = TextBox2.Value
ActiveCell.Offset(0, 2) = TextBox3.Value
ActiveCell.Offset(1, 0).Select
With:
Dim last As Long
With Worksheets("Sheet1")
last = .Cells(.Rows.Count, "A").End(xlUp).row
.Range("A" & last + 1).Value = TextBox1.Value
.Range("B" & last + 1).Value = TextBox2.Value
.Range("C" & last + 1).Value = TextBox3.Value
End With
Change the Worksheet Event Code to this: (Untested)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
test = Worksheets("Sheet2").Cells(3, 3).Value
With Worksheets("Sheet1")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
calc = .Cells(i, "C").Value
.Cells(i, "D").Value = Abs(test - calc)
Next i
.Range("A:D").Sort Key1:=.Range("D2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Application.EnableEvents = True
End With
End If
End Sub
Demo:
Updated Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim test As Variant
Dim calc As Variant
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Application.EnableEvents = False
Dim lst As Long
test = Worksheets("Target Answer").Cells(3, 3).Value
With Worksheets("Consolidation")
lst = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 3 To lst
calc = .Cells(i, "E").Value
.Cells(i, "F").Value = Abs(test - calc)
Next i
.Range("C2:F" & lst).Sort Key1:=.Range("F3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Application.EnableEvents = True
End With
End If
End Sub
I have a complex workbook that i need filtered using vba.
I need to delete rows that have blank cells from column G.
I then need columns C through G hidden.
Then I need Column H filtered to delete all rows greater than 2.
Finally I need Column I sorted from Largest to smallest.
This is what i have so far but It half way works and i don't want to use a command button. I want to be able to paste a document in here and the code automatically works it.
Private Sub CommandButton1_Click()
'Created by William Hinebrick 277096
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Please select range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If (xRg.Areas.Count > 1) Or (xRg.Columns.Count > 1) Then
MsgBox "You can only select one column per time", vbInformation, "Kutools for Excel"
Exit Sub
End If
xRg.Range("A1").EntireRow.Insert
Set xRg = xRg.Range("A1").Offset(-1).Resize(xRg.Rows.Count + 1)
xRg.Range("A1") = "Temp"
xRg.AutoFilter 1, ">2"
Set xRg = Application.Intersect(xRg, xRg.SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If Not xRg Is Nothing Then xRg.EntireRow.Delete
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Created by William Hinebrick 277096
Dim xRg As Range
Application.ScreenUpdating = False
For Each xRg In Range("G1:G10000")
If xRg.Value = "" Then
xRg.EntireRow.Hidden = True
Else
xRg.EntireRow.Hidden = False
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Sub Column_Hide()
'Created by William Hinebrick 277096
Columns("C:G").EntireColumn.Hidden = True
Columns("J").EntireColumn.Hidden = True
End Sub
Private Sub Sort_Drop(ByVal Target As Range)
On Error Resume Next
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub
I would like to be able to use this daily as I will be pasting New spreadsheets to this worksheet to be filtered so I may concise the results
This should do everything listed.
If you require it to perform everytime you copy data in, then the Worksheet_Changeevent from your 2nd sub is the way to go. But this means it also runs every other time you change something in your workbook. I'd personally simply assign a Keyboard shortcut to it. Seems the easiest way to go.
Option Explicit
Sub test()
Dim i As Double
Dim lastrow As Double
lastrow = ActiveSheet.UsedRange.Rows.Count
For i = lastrow To 2 Step (-1) 'delete empty G cells
If ActiveSheet.Cells(i, 7).Value = "" Then Cells(i, 7).EntireRow.Delete
Next
lastrow = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
For i = lastrow To 2 Step (-1) 'delete H >2
If ActiveSheet.Cells(i, 8).Value > 2 Then Cells(i, 8).EntireRow.Delete
Next
Columns("C:G").EntireColumn.Hidden = True 'hide columns
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom 'Sort by I descending order
End Sub
I need your help.
Sorry, I am really new to VBA but, how do I go about converting or adding onto the Excel function below to loop through all the found matches. Right now it only returns 1 match but i'd like to to have it modified to return all occurrences of a match so that I can input it into my userform for processing later.
Private Sub Search_Click()
With Sheet1
Set foundCell = .Cells.find(What:="test", After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Match"" found in row " & foundCell.Row)
form1.location.Value = Cells(foundCell.Row, 1).Value
Else
MsgBox ("No match not found")
End If
End Sub
You can try findnext or add some small edits like something along these lines, just a continuous loop until you run out of matches
Private Sub Search_Click()
Dim rowNum As Long: rowNum = 1
Dim colNum As Long: colNum = 1
Do While ( True )
With Sheet1
Set foundCell = .Cells.find(What:="test", After:=.Cells(rowNum, colNum), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Match"" found in row " & foundCell.Row)
form1.location.Value = form1.location.Value & vbCrLf & Cells(foundCell.Row, 1).Value
if foundCell.Row < rowNum Then Exit Do
rowNum = foundCell.Row
colNum = foundCell.Column
Else
If rowNum = 1 Then MsgBox ("No matches found")
Exit Do
End If
Loop
End Sub
Just in case you need to store data for all cells that contained your search item, you could use the following. Usage: myArray = makeArrayFoundCellInfoInRange("test", Sheets.("Sheet1").Range("A1:Z500"))
'**************************************************************************************************************************************************************
'To return an array of information (value, formula, address, row, and column) for all the cells from a specified Range that have the searched item as value
'Returns an empty array if there is an error or no data
'**************************************************************************************************************************************************************
Public Function makeArrayFoundCellInfoInRange(ByVal itemSearched As Variant, ByVal aRange As Variant) As Variant
Dim cell As Range, tmpArr As Variant, x As Long
tmpArr = Array()
If TypeName(aRange) = "Range" Then
x = 0
For Each cell In aRange
If itemSearched = cell.Value Then
If x = 0 Then
ReDim tmpArr(0 To 0, 0 To 4)
Else
tmpArr = reDimPreserve(tmpArr, UBound(tmpArr, 1) + 1, UBound(tmpArr, 2))
End If
tmpArr(x, 0) = cell.Value
tmpArr(x, 1) = cell.Formula
tmpArr(x, 2) = cell.Address(0, 0) 'Without the dollar signs
tmpArr(x, 3) = cell.Row
tmpArr(x, 4) = cell.Column
x = x + 1
End If
Next cell
End If
makeArrayFoundCellInfoInRange = tmpArr
Erase tmpArr
End Function
people, my doubts is simple .. I created a spreadsheet in excel with several fields, eg:
NAME ADDRESS PHONE
carlos ave. 1 12345678
Argeu av .2 87654321
After this, I used the following code in the module:
Private Sub Worksheet_Activate()
ActiveSheet.ScrollArea = "$A$2:$A$300"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
Dim LR As Long
LR = Cells(Rows.Count, "A").End(xlUp).Row
Range("$A$2:$A" & LR).Sort Key1:=Range("$A$2")
End Sub
This code will make in the example table, the Argeu stand on the carlos, so far so good, but I want when the Argeu is up from carlos the phone and address data also rise ..
If anyone can help, thank you
IF you want Col C to be also sorted then include that in the sort range as well. See this.
Change
Range("$A$2:$A" & LR).Sort Key1:=Range("$A$2")
to
Range("$A$2:$C" & LR).Sort Key1:=Range("$A$2")
EDIT
Your code can be properly re-written as
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
'~~> For xl2007+ use .CountLarge
If Target.Cells.CountLarge > 1 Then Exit Sub
'~~> For xl2003 use .Count
'If Target.Cells.Count > 1 Then Exit Sub
Dim LR As Long
If Application.WorksheetFunction.CountA(Cells) <> 0 Then
LR = Cells.Find(What:="*", _
After:=Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LR = 1
End If
Range("$A$2:$C" & LR).Sort Key1:=Range("$A$2")
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
ScreenShot