Can you help me with edit macro? I would like to search on another sheet but I don't known what I do wrong. Sheet where I would like to search is "Díly".
Sub díly()
Dim rngVis As Range
Dim VisCell As Range
Dim sFind As String
sFind = InputBox("Naskenujte zákaznické císlo.")
If Len(Trim(sFind)) = 0 Then Exit Sub 'Pressed cancel
Application.ScreenUpdating = False
With Intersect(Sheets("Díly").UsedRange, Sheets("Díly").Columns("A"))
.AutoFilter 1, sFind
On Error Resume Next
Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
End With
Application.ScreenUpdating = True
If rngVis Is Nothing Then
MsgBox sFind & " Nenalezeno."
Else
For Each VisCell In rngVis.Cells
MsgBox "Naskenované císlo: " & VisCell.Sheets("Díly").Cells(VisCell.Row, "A").Text & vbNewLine & _
"Vyhledáno: " & VisCell.Sheets("Díly").Cells(VisCell.Row, "B").Text
Next VisCell
End If
End Sub
try this
Option Explicit
Sub díly()
Dim rngVis As Range
Dim VisCell As Range
Dim sFind As String
sFind = InputBox("Naskenujte zákaznické císlo.")
If Len(Trim(sFind)) = 0 Then Exit Sub 'Pressed cancel
Application.ScreenUpdating = False
With Intersect(Sheets("Díly").UsedRange, Sheets("Díly").Columns("A"))
.AutoFilter 1, sFind
On Error Resume Next
Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
End With
Application.ScreenUpdating = True
If rngVis Is Nothing Then
MsgBox sFind & " Nenalezeno."
Else
For Each VisCell In rngVis.Cells
MsgBox "Naskenované císlo: " & VisCell.Text & vbNewLine & _
"Vyhledáno: " & VisCell.Offset(, 1).Text
Next VisCell
End If
End Sub
Related
The code below will "exit for" after it meets its condition once even if there are more in the range that meet the condition. How do I correct this?
Private Sub cmdAdd_Click()
On Error GoTo Whoa
Dim LastRow As Long, i As Long
LastRow = ActiveSheet.Range(Me.txtTaskCol.Value & Rows.Count).End(xlUp).Row
'Copy input values to sheet
For i = 1 To LastRow
If UCase(CStr(ActiveSheet.Range(Me.txtTaskCol.Value & i).Value)) = UCase(CStr(Me.txtTask.Value)) Then
ActiveSheet.Range(Me.txtUnitCol.Value & i).Value = Me.txtQuantity.Value
Exit For
Else
If i = LastRow Then MsgBox "Task Not Found!"
End If
Next i
'Clear input controls
Me.txtTask.Value = ""
Me.txtQuantity.Value = ""
Exit Sub
Whoa:
Select Case Err.Number
Case 1004
MsgBox "Check for Valid Column Letters!"
End Select
End Sub
Echoing K.Davis comment, not sure why you would want to exit?
I made some edits to your code. Error handling is not included, but the code should complete the loop and tell you if nothing is found.
Private Sub cmdAdd_Click()
On Error GoTo Whoa
Dim LastRow As Long, i As Long
LastRow = ActiveSheet.Range(Me.txtTaskCol.Value & Rows.Count).End(xlUp).Row
'Set a counter so you can message Task Not Found
Dim matchCounter as Integer
matchCounter = 0
'Copy input values to sheet
For i = 1 To LastRow
If UCase(CStr(ActiveSheet.Range(Me.txtTaskCol.Value & i).Value)) = _
UCase(CStr(Me.txtTask.Value)) Then
ActiveSheet.Range(Me.txtUnitCol.Value & i).Value = Me.txtQuantity.Value
matchCounter = matchCounter + 1
End If
Next i
If matchCounter = 0 then MsgBox "Nothing Found"
'Clear input controls
Me.txtTask.Value = ""
Me.txtQuantity.Value = ""
Exit Sub
End Sub
Hope it's helpful.
Just use a boolean flag that will set the flag to True if your If...Then statement is true one time:
If you are wanting to continue your For...Next statement after you meet the criteria, then you don't want to exit for.
Private Sub cmdAdd_Click()
On Error GoTo Whoa
Dim LastRow As Long, i As Long, tskFlg As Boolean
LastRow = ActiveSheet.Range(Me.txtTaskCol.Value & Rows.Count).End(xlUp).Row
'Copy input values to sheet
For i = 1 To LastRow
If UCase(CStr(ActiveSheet.Range(Me.txtTaskCol.Value & i).Value)) = UCase(CStr(Me.txtTask.Value)) Then
ActiveSheet.Range(Me.txtUnitCol.Value & i).Value = Me.txtQuantity.Value
tskFlg = True
End If
Next i
If tskFlg = False Then MsgBox "Task Not Found!"
'Clear input controls
Me.txtTask.Value = ""
Me.txtQuantity.Value = ""
Exit Sub
Whoa:
Select Case Err.Number
Case 1004
MsgBox "Check for Valid Column Letters!"
End Select
End Sub
following my post If cell value matches a UserForm ComboBox column, then copy to sheet.
I have managed to get the code to work to move the check the names and move then to the correct sheets.
The problem i am having is checking if the sheets exists. If it finds a match in the sheet and column 2 in the combobox but there is no sheet for the value then it crashes the code.
Once all the information has been copied to the relevant sheets, i would like it to display a msgbox telling the user how many rows of data have been copied to the respective sheets.
Dim i As Long, j As Long, lastG As Long, strWS As String, rngCPY As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
On Error GoTo bm_Close_Out
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
' loop over values in "details"
For j = 0 To Me.ComboBox2.ListCount - 1
currVal = Me.ComboBox2.List(j, 2) ' value to match
If lookupVal = currVal Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next j
Next i
GoTo bm_Close_Out
bm_Need_Worksheet:
On Error GoTo 0
With Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = Me.ComboBox2.List(j, 0)
Dim lastRow As Long: lastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("A20").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " - " & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("A20").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " - " & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & lastRow + 1).value = NewName & ": "
.Range("V" & lastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & lastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & lastRow + 1).Formula = "='" & NewName & "'!K21"
End With
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
With help from Jeeped I have manage to get the code for copying the rows to the relevant sheets, and if the sheet doesn't exists then it create it. I just need help with problem two above.
Attempting to use a Worksheet Object that does not exist throws an error. If you catch that error and create a worksheet with the name that you are looking for, you can Resume back to the point where the error was thrown and continue your processing.
Private Sub CommandButton7_Click()
Dim i As Long, j As Long, lastG As Long, strWS As String, strMSG As String
dim rngHDR as range, rngCPY aS range
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
On Error GoTo bm_Close_Out
' find last row
lastG = Sheets("Global").Cells(Rows.Count, "Q").End(xlUp).Row
For i = 3 To lastG
lookupVal = Sheets("Global").Cells(i, "Q") ' value to find
' loop over values in "details"
For j = 0 To Me.ComboBox2.ListCount - 1
currVal = Me.ComboBox2.List(j, 2) ' value to match
If lookupVal = currVal Then
set rngHDR = Sheets("Global").Cells(1, "Q").EntireRow
set rngCPY = Sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With WorkSheets(strWS)
rngCPY .copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
exit for
End If
Next j
if j >= Me.ComboBox2.ListCount then _
strMSG = strMSG & "Not found: " & lookupVal & chr(10)
Next i
GoTo bm_Close_Out
bm_Need_Worksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = strWS
'maybe make a header row here; watch out you do not lose your copy
rngHDR.copy destination:=.cells(1, 1)
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = False
End With
debug.print strMSG
'the next is NOT recommended as strMSG could possibly be VERY long
'if cbool(len(strMSG)) then msgbox strMSG
End Sub
There is a question about whether the new worksheet needs a column header label row but that should be fairly easily rectified.
You could use a function like this :
Sub test_atame()
Dim Ws As Worksheet
Set Ws = Sheet_Exists(ThisWorkbook, "Sheet1")
Set Ws = Sheet_Exists(ActiveWorkbook, "Sheet1")
End Sub
Here is the function :
Public Function Sheet_Exists(aWorkBook As Workbook, Sheet_Name As String) As Worksheet
Dim Ws As Worksheet, _
SExistS As Boolean
SExistS = False
For Each Ws In aWorkBook.Sheets
If Ws.Name <> Sheet_Name Then
Else
SExistS = True
Exit For
End If
Next Ws
If SExistS Then
Set Sheet_Exists = aWorkBook.Sheets(Sheet_Name)
Else
Set Sheet_Exists = Nothing
MsgBox "The sheet " & Sheet_Name & " wasn't found in " & aWorkBook.Name & vbCrLf & _
"Break code to check and correct.", vbCritical + vbOKOnly
End If
End Function
Maybe a check like:
Public Function SheetExists(ByVal Book As Workbook, ByVal SheetName As String) As Boolean
On Error Resume Next
Dim wsTest As Worksheet
Set wsTest = Book.Worksheets(SheetName)
If Not wsTest Is Nothing Then SheetExists = True
End Function
I am trying to copy excel row in different worksheet sheet 2 when cell dropdown "Yes" of Column F and when "No" removes the row if "Yes" was selected previously. I also wanted to check if duplicate exists in worksheet 2, then prompt user with "Yes", "No" button. If "Yes" then duplicate if "No" do nothing.
ColA:Customer Name ColB:Customer Address ColC:Customer City ColD:Cust zip ColE:Tel ColF:Yes/No
I have tried this.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lastrow As Long
If UCase(Range("F" & ActiveCell.Row).Value) <> "YES" Then Exit Sub
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
If WorksheetFunction.CountIf(.Range("A1:A" & lastrow), _
Range("A" & ActiveCell.Row).Value) > 0 Then Exit Sub
Response = MsgBox("Record already exists, add again?", vbQuestion + vbYesNo + 256)
If Response = vbNo Then Exit Sub
.Range("A" & lastrow).Resize(, 5).Value = _
Range("A" & ActiveCell.Row).Resize(, 5).Value
End With
Response = MsgBox("Record added")
End Sub
If I understand you correctly, you need something like this (code runs only if changed value in column F):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
Dim Response
Dim rng As Range, rngToDel As Range
Dim fAddr As String
If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error GoTo ErrHandler
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
If UCase(Target.Value) = "YES" Then
Response = vbYes
If WorksheetFunction.CountIf(.Range("A1:A" & lastrow), _
Range("A" & Target.Row).Value) > 0 Then
Response = MsgBox("Record already exists, add again?", vbQuestion + vbYesNo + 256)
End If
If Response = vbYes Then
.Range("A" & lastrow).Resize(, 5).Value = _
Range("A" & Target.Row).Resize(, 5).Value
MsgBox "Record added"
End If
ElseIf UCase(Target.Value) = "NO" Then
With .Range("A4:A" & lastrow)
Set rng = .Find(What:=Range("A" & Target.Row), _
LookIn:=xlValues, _
lookAt:=xlWhole, _
MatchCase:=False)
If Not rng Is Nothing Then
fAddr = rng.Address
Do
If rngToDel Is Nothing Then
Set rngToDel = rng.Resize(, 5)
Else
Set rngToDel = Union(rngToDel, rng.Resize(, 5))
End If
Set rng = .FindNext(rng)
If rng Is Nothing Then Exit Do
Loop While fAddr <> rng.Address
End If
If Not rngToDel Is Nothing Then
rngToDel.Delete Shift:=xlUp
MsgBox "Records from sheet2 removed"
End If
End With
End If
End With
ExitHere:
Application.EnableEvents = True
Exit Sub
ErrHandler:
Resume ExitHere
End Sub
I would like to use values from each instance of the string FindString to populate textboxes in UserForm1.
I am getting the unique WorkSheet per textbox. But the rest of the values are from the sheet active when I run the module.
This mean the string Rng isn't looping through the WorkSheets, but staying with the initial WorkSheet. How can I remedy this?
Public Sub FindString()
Dim FindString As Variant
Dim Rng As Range
Dim SheetName As String
Dim ws As Worksheet
Dim i As Integer
Application.ScreenUpdating = False
SheetName = ActiveSheet.Name
FindString = Cells(ActiveCell.Row, 1).Value
FindString = InputBox("Enter the case number to search for:", "Case ID", FindString)
If FindString = "" Then Exit Sub
If FindString = False Then Exit Sub
i = 1
For Each ws In Worksheets
If ws.Name Like "Lang*" Then
With ws
If Trim(FindString) <> "" Then
With Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
UserForm1.Controls("TextBox" & i) = ws.Name & vbTab & _
Rng.Offset(0, 2).Value & vbTab & _
Rng.Offset(0, 5).Value & vbTab & _
Rng.Offset(0, 6).Value & vbTab & _
Rng.Offset(0, 7).Value & vbTab & _
Rng.Offset(0, 8).Value
i = i + 1
Else: GoTo NotFound
End If
End With
End If
End With
End If
Next ws
Sheets(SheetName).Activate
Application.ScreenUpdating = True
UserForm1.Show
Exit Sub
NotFound:
Sheets(SheetName).Activate
Application.ScreenUpdating = True
MsgBox "Case ID not found"
Exit Sub
End Sub
Got it!
Just needed to add
ws.Activate
after
If ws.Name Like "Lang*" Then
the code below works fine. However, when a user doesn't include anything in the InputBox or clicks on the 'Close' button or inputs a value which doesn't exist I want it to display a msgbox stating the reason and delete sheets 'PreTotal'.
Is there a better way to handle user input? Need some help here on how to go about it. Thank you.
Sub Filterme()
Dim wSheetStart As Worksheet
Dim rFilterHeads As Range
Dim strCriteria As String
Set wSheetStart = ActiveSheet
Set rFilterHeads = Range("M1", Range("M1").End(xlToLeft))
With wSheetStart
.AutoFilterMode = False
rFilterHeads.AutoFilter
strCriteria = InputBox("Enter Date - MMDDYY")
If strCriteria = vbNullString Then Exit Sub
rFilterHeads.AutoFilter Field:=13, Criteria1:="=*" & strCriteria & "*"
End With
Worksheets("PreTotal").UsedRange.Copy
Sheets.Add.Name = "Total"
Worksheets("Total").Range("A1").PasteSpecial
End Sub
Is this what you are trying?
Change
If strCriteria = vbNullString Then Exit Sub
to
If strCriteria = vbNullString Then
MsgBox "You choose not to continue"
Application.DisplayAlerts = False
Worksheets("PreTotal").Delete
Application.DisplayAlerts = True
Exit Sub
End If
FOLLOWUP
Thanks #Rout - This worked. One more thing what if the input criteria does not exist in the sheet? How should I tackle that? – user823911 11 mins ago
Is this what you are trying? Also if you are filtering the range based on Col M (1st Col in the range) then change the line
rFilterHeads.AutoFilter Field:=13, Criteria1:="=*" & strCriteria & "*"
to
rFilterHeads.AutoFilter Field:=1, Criteria1:="=*" & strCriteria & "*"
CODE
Sub Filterme()
Dim wSheetStart As Worksheet
Dim rFilterHeads As Range, aCell As Range
Dim strCriteria As String
Set wSheetStart = ActiveSheet
Set rFilterHeads = Range("M1", Range("M1").End(xlToLeft))
With wSheetStart
.AutoFilterMode = False
strCriteria = InputBox("Enter Date - MMDDYY")
If strCriteria = vbNullString Then
MsgBox "You choose not to continue"
Application.DisplayAlerts = False
Worksheets("PreTotal").Delete
Application.DisplayAlerts = True
Exit Sub
End If
Set aCell = .Columns(13).Find(What:=strCriteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
MsgBox "Search Criteria Not Found"
Exit Sub
End If
rFilterHeads.AutoFilter
rFilterHeads.AutoFilter Field:=13, Criteria1:="=*" & strCriteria & "*"
Sheets.Add.Name = "Total"
Worksheets("PreTotal").UsedRange.Copy
Worksheets("Total").Range("A1").PasteSpecial
End With
End Sub