Im new to VBA and Im trying to add a "search" command button to this "listform" but things are not like expected.Bellow what I tried and every single time I try to search something it`s comming back with a debug for SMTPTH_ListBox.Clear
Can someone help here please?
Thanks in advance
Private Sub CommandButton1_Click()
Dim rFilter As Range
Dim pc As String
pc = PNSearch_TextBox.Value
SMTPTH_ListBox.Clear
With Sheet1
If .FilterMode Then .ShowAllData
With .Range("A1:AI" & .Cells(.Rows.Count, "AI").End(xlUp).Row)
.AutoFilter Field:=4, Criteria1:="=*" & pc & "*", Operator:=xlAnd
On Error Resume Next
Set rFilter = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rFilter Is Nothing Then
Call UpdateListBox1(rFilter)
End If
'.AutoFilter
End With
End With
End Sub
Private Sub UpdateListBox1(ByVal rSourceRange As Range)
Dim rRow As Range
Dim i As Long
Dim j As Long
i = 0
For Each rRow In rSourceRange.Rows
With SMTPTH_ListBox
.AddItem rRow.Cells(1, 1)
For j = 1 To rRow.Cells.Count - 1
.List(i, j) = rRow.Cells(1, j + 1).Value
Next j
End With
i = i + 1
Next rRow
End Sub
Related
I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub
This is just a sample I am testing the code in this data. I have three columns in sheet2. I have to delete the empty cells. This is the updated code which is working for column B only. You can check the snapshot
Sub delete()
Dim counter As Integer, i As Integer
counter = 0
For i = 1 To 10
If Cells(i, 1).Value <> "" Then
Cells(counter + 1, 2).Value = Cells(i, 1).Value
counter = counter + 1
End If
Next i
End Sub
Sample screenshot
If all you want is to delete the empty cells, give this a try...
Sub DeleteBlankCells()
Dim rng As Range
On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Range("A:C"))
rng.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub
Not the most elegant solution but it works.
Option Explicit
Sub delete()
Dim rCells As Range, rCell As Range, sFixCell As String
Set rCells = Range("A1:A13")
For Each rCell In rCells
If rCell = "" Then
sFixCell = rCell.Address
Do While rCell.Value = ""
rCell.delete Shift:=xlUp
Set rCell = Range(sFixCell)
Loop
End If
Next rCell
End Sub
I have this sheet where I applied a series of subs to get what I want. The last one is an Advanced Filter.
You can see how my main sheet is below:
My criteria is C31:K32 and the results should be pasted from line 38. It gets the information from that sheet called AUX:
The complete code is below:
Sub FiltroAloc()
Dim i As Long
Dim j As Long
Dim Lastrow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim res
Set ws1 = Sheets("CONSULTA")
Set ws2 = Sheets("BASE_TOTAL_ATUAL")
Set ws3 = Sheets("AUX")
For i = 1 To 100
For j = 1 To 11
If ((ws1.Cells(29, 5).Value < ws2.Cells(i, 7).Value) And (ws1.Cells(29, 6).Value > ws2.Cells(i, 7).Value)) Or ((ws1.Cells(29, 5).Value < ws2.Cells(i, 8).Value) And (ws1.Cells(29, 6).Value > ws2.Cells(i, 8).Value)) Then
ws3.Cells(i, j) = ws2.Cells(i, j).Value
ElseIf (ws1.Cells(29, 5) = "") And (ws1.Cells(29, 6) = "") Then
ws3.Cells(i, j) = ws2.Cells(i, j).Value
End If
Next j
Next i
Call Esvaziar
End Sub
Sub Esvaziar()
Dim r As Range, rows As Long, i As Long
Dim ws As Worksheet
Set ws = Sheets("AUX")
Set r = ws.Range("A1:K450")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then
r.rows(i).Delete
End If
Next
Call AutoFilter
End Sub
All my code works fine! After that, I started to record my Advanced Filter as a Macro with AutoFilter name.
When I finished to record it worked fine and load all information, because I recorded it with nothing in my criteria.
The problem is when I assing to my "Filtrar" button. It gave me
Run-time error '1004' - Method 'Range' of object'_Global' failed
And that is the code:
Sub AutoFilter()
'
' AutoFilter Macro
'
'
Sheets("AUX").Range("A1:K176").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:="CONSULTA!Criteria", CopyToRange:=Range("CONSULTA!Extract") _
, Unique:=False
ActiveWindow.SmallScroll Down:=-21
Range("G3").Select
End Sub
And the highlighted part:
Sheets("AUX").Range("A1:K176").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:="CONSULTA!Criteria", CopyToRange:=Range("CONSULTA!Extract") _
, Unique:=False
I tried a lot of things but I guess I'm missing something. I don't know where to find my range problem... Any suggestions will be appreciated.
Try it with CriteriaRange:=worksheets("CONSULTA").Range("Criteria") and CopyToRange:=worksheets("CONSULTA").Range("Extract")
Sheets("AUX").Range("A1:K176").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=worksheets("CONSULTA").Range("Criteria"), _
CopyToRange:=worksheets("CONSULTA").Range("Extract"), Unique:=False
I want to create a macro which will vlookup in another sheet and change the value in the vlook up cell by another user defined value.
I wrote a very basic code which full fills my need, but it is very slow and its one run takes almost 3 minutes.
Can you please suggest an easier way out or just suggest what is wrong with my code.
Private Sub CommandButton1_Click()
Dim myCell As Range
Dim myLookup
Dim i As Integer
i = Sheets("Modify Order").Cells(5, 2).Value
For Each myCell In Sheets("Customer List").Range("E:E")
If myCell.Value = Sheets("Modify Order").Cells(4, 2).Value Then
myCell.Offset(0, i).Value = Sheets("Modify Order").Cells(7, 2).Value
End If
Next myCell
MsgBox "Done!"
End Sub
It is always very slow iterating cell-by-cell: better to use variant arrays instead:
Sub CommandButton1_Click()
Dim vArrColE As Variant
Dim vArrColChange As Variant
Dim myLookup As Variant
Dim myChangeTo As Variant
Dim j As Long
Dim jLastRow As Long
Dim kCol As Long
Dim nChanged As Long
Dim lCalc As Long
lCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
myLookup = Sheets("Modify Order").Cells(4, 2).Value2
myChangeTo = Sheets("Modify Order").Cells(7, 2).Value2
kCol = Sheets("Modify Order").Cells(5, 2).Value2
jLastRow = Sheets("Customer List").Cells(Rows.Count, 5).End(xlUp).Row
'
' get columns into variant arrays
'
vArrColE = Sheets("Customer List").Range("E1:E" & jLastRow).Value2
vArrColChange = Sheets("Customer List").Cells(1, kCol).Resize(jLastRow, 1).Value2
For j = LBound(vArrColE) To UBound(vArrColE)
If vArrColE(j, 1) = myLookup Then
vArrColChange(j, 1) = myChangeTo
nChanged = nChanged + 1
End If
Next j
'
' put changed column back
'
Sheets("Customer List").Cells(1, kCol).Resize(jLastRow, 1).Value2 = vArrColChange
Application.Calculation = lCalc
MsgBox "Changed " & nChanged & " Cells"
End Sub
I'd use AutoFilter():
Option Explicit
Private Sub CommandButton1_Click()
Dim myLookup As Variant
Dim i As Integer
With Sheets("Modify Order")
i = .Cells(5, 2).Value
myLookup = .Cells(4, 2).Value
End With
With Sheets("Customer List")
With .Range("E1", .Cells(.Rows.count, "E").End(xlUp))
.AutoFilter Field:=1, Criteria1:=myLookup
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Offset(1, i).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible).Value = Sheets("Modify Order").Cells(7, 2).Value
End With
.AutoFilterMode = False
End With
MsgBox "Done!"
End Sub
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