First off, just starting trying to learn Excel and VBA yesterday....so bear in mind.
Private Sub CommandButton2_Click()
For a = 1 To myLastRow
Select Case ActiveWorkbook.Sheets("Sheet2").Cells(a, 2).Value
Case Is = myOrderNumber
ActiveWorkbook.Sheets("Sheet2").Cells(a, 2).Active
Case False: MsgBox "False"
End Select
Next a
End Sub
I want to know which cell or the row of the cell that matches my variable. This does not do what I want.......
Thanks guys
I appreciate you are learning code. But beyond getting the range syntax correct two better methods (efficiency wise) are shown below
Array
recut
Private Sub CommandButton2_Click()
Dim myLastRow As Long
Dim myOrderNumber As Long
Dim lngCnt As Long
Dim ws As Worksheet
Dim X
myOrderNumber = 2
Set ws = ActiveWorkbook.Sheets("Sheet2")
X = ws.Range(ws.[b1], ws.[b10])
For lngCnt = 1 To UBound(X)
If X(lngCnt, 1) = myOrderNumber Then MsgBox "True " & lngCnt
Next
End Sub
Evaluate
From Is it possible to fill an array with row numbers which match a certain criteria without looping?
myOrderNumber = 2
MsgBox Join(Filter(Application.Transpose(Application.Evaluate("=IF(B1:B10=" & myOrderNumber & ",ROW(B1:B10),""x"")")), "x", False), ",")
Try this
Private Sub CommandButton2_Click()
Dim myLastRow As Long, a As Long, myOrderNumber As Long
myLastRow = 10
For a = 1 To myLastRow
With ActiveWorkbook.Sheets("Sheet2")
If .Cells(a, 2).Value = myOrderNumber Then
MsgBox "True " & .Cells(a, 2).Row
Else
Msgbox "False"
End If
End With
Next a
End Sub
For a = 1 To myLastRow
With ActiveWorkbook.Sheets("Sheet2")
If .Cells(a, 2).Value = myOrderNumber Then
myRow = .Cells(a, 2).Row
MsgBox "True " & myRow
Else
'MsgBox "False "
End If
End With
Next a
Related
I doesnt find a solution for my problem in the WWW.
Hope you can help me:
I've imported a long text file with various information: it looks like this:
id 5
name node1
UPS_serial_number
WWNN 500507680350BD
status online
IO_group_id 0
IO_group_name io_grp0
partner_node_id 4
partner_node_name node2
config_node yes
UPS_unique_id
port_id 500507680456454
port_status active
port_speed 8Gb
port_id 500507680545644
port_status active
port_speed 8Gb
id 4
name node2
UPS_serial_number
WWNN 500507680200DDE8
status online
IO_group_id 0
IO_group_name io_grp0
partner_node_id 4
partner_node_name node1
config_node yes
UPS_unique_id
port_id 5005076803594BDE
port_status active
port_speed 8Gb
port_id 500507680235486F
port_status active
port_speed 8Gb
.
.
.
Its almost formatted in the right format like this:
[string || value]
I want to look in the first block and get the infos for name, id, WWPN - then copy the values to another worksheet.
Then look into the second block and get the same infos: name, id, WWPN and copy them.
Then next block and the next block and so on.
I have the following code:
Sub find_test()
Dim rng As Range
Dim rngCell As Variant
Dim LR As Long
Dim tRow
LR = Cells(1, 1).End(xlDown).Row
Set rng = Range("A1:A" & LR)
For Each rngCell In rng.Cells
tRow = rngCell.Row
If StrComp(rngCell.Value, "name") = 0 Then 'Node 1 Service IP
Worksheets("temp").Range("E16").Value = Worksheets("lsnodecanister").Range("B" & tRow).Value
End If
Next
End Sub
The Text blocks are almost seperated by an empty row.
Do you have any idea?
Hope it was understandable.
Thank you very much,
Best regards,
Kalain
something like
Sub SO1()
Dim lngRow As Long
Dim lngLastRowOfSection As Long
Dim rngFind As Range
Dim strName As String
lngRow = 1
Do Until Cells(lngRow + 1, 1).Value = ""
lngLastRowOfSection = Cells(lngRow, 1).End(xlDown).Row
Set rngFind = Range(Cells(lngRow, 1), Cells(lngLastRowOfSection, 1)).Find("name")
If Not rngFind Is Nothing Then
strName = rngFind.Offset(0, 1).Value
Debug.Print strName
End If
lngRow = Cells(lngLastRowOfSection, 1).End(xlDown).Row
If lngRow >= Rows.Count Then Exit Do
Loop
End Sub
I might have misunderstood the question. I think you meant that each line of your data has the name and data separated by a space. I manipulated your subroutine to put all values in column a into an array and then I split the array into columns B and C.
Sub find_test()
Dim rng As Range
Dim LR As Long
Dim tRow As Long
Dim myArray() As Variant, arrayCounter As Long
Dim lilStringArray
'
LR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
ReDim myArray(1 To 1)
arrayCounter = 1
myArray = Range("A1:A" & LR)
tRow = 1
For i = LBound(myArray) To UBound(myArray)
If myArray(i, 1) <> "" Then
lilStringArray = Split(myArray(i, 1), " ")
Range("B" & tRow).Value = lilStringArray(0)
On Error Resume Next
Range("C" & tRow).Value = lilStringArray(1)
On Error GoTo 0
Else
Range("C" & tRow).Value = ""
End If
tRow = tRow + 1
Next i
End Sub
Basically, have this code which uses Vlookups and a match to find past order dates of a particular product. The sub fills text boxes in a userform with N/A if there are no past orders found in the sheet. Otherwise, finds the latest order and fills the information in the userform.
The program stops when this sub routine is called. Getting 'subscript out of range' (error 9), I run the debugger and go through the code and everything works the way it is supposed to. In both the N/A case and the case where there is past order info.
Sub PastOrderInfo()
Dim wks As Worksheet
Dim Date_Ordered As Variant
Dim PreviousDate As Variant
Dim Qty_Ordered As String
Dim Total_Cost As String
Dim Rng, RngCol As String
Dim Last_Row As Long
Dim i, NewRow As Integer
Set wks = Worksheets("Order Data")
With wks
Last_Row = .UsedRange.Rows(.UsedRange.Rows.count).Row
Rng = "A2:D" & Last_Row
RngCol = "A2:A" & Last_Row
For i = 2 To Last_Row
If i = 2 Then
On Error Resume Next
PreviousDate = Application.VLookup(CStr(ProdNum), .Range(Rng), 2, False)
On Error GoTo 0
If IsError(PreviousDate) Then
Me.TextBox4.Value = "N/A"
Me.TextBox5.Value = "N/A"
Me.TextBox6.Value = "N/A"
Exit Sub
End If
NewRow = Application.Match(CStr(ProdNum), .Range(RngCol), 0) + 2
Rng = "A" & NewRow & ":D" & Last_Row
RngCol = "A" & NewRow & ":A" & Last_Row
ElseIf i > 2 Then
On Error Resume Next
Date_Ordered = Application.VLookup(CStr(ProdNum), .Range(Rng), 2, False)
On Error GoTo 0
If IsError(Date_Ordered) Then
NewRow = NewRow - 1
Rng = "A" & NewRow & ":D" & Last_Row
Me.TextBox4.Value = CDate(PreviousDate)
Me.TextBox5.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 3, False)
Me.TextBox6.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 4, False)
Exit Sub
End If
NewRow = Application.Match(CStr(ProdNum), .Range(RngCol), 0) + NewRow
Rng = "A" & NewRow & ":D" & Last_Row
RngCol = "A" & NewRow & ":A" & Last_Row
If Date_Ordered > PreviousDate Then PreviousDate = Date_Ordered
End If
Next i
Me.TextBox4.Value = CDate(PreviousDate)
Me.TextBox5.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 3, False)
Me.TextBox6.Value = Application.VLookup(CStr(ProdNum), .Range(Rng), 4, False)
End With
End Sub
Here is the line which is the section of code which opens the userform, when I click to debug it highlights the ProDescription.Show line below the if .Range(cellselect)...:
Private Sub CommandButton1_Click()
Dim i, r, c As Integer
Dim wks As Worksheet
Dim cellselect As String
Set wks = Workbooks("Data Direct Orders2.xlsx").Worksheets("Direct Items")
With wks
If ProdNumberCmbBox.ListIndex = -1 Then
Unload Me
ErrorMsg.Show
End
Else
For r = 2 To 84
cellselect = "A" & r
If .Range(cellselect).Text = ProdNum Then
ProDescription.Show
Unload Me
End
End If
Next r
If c = 0 Then
Unload Me
ErrorMsg.Show
End
End If
End If
End With
End Sub
Here is the sub routine where the userform is initialized:
Private Sub UserForm_Initialize()
TextBox8.Value = ProdNum
Call PastOrderInfo
End Sub
Just figured it out.
The line:
Set wks = Worksheets("Order Data")
in
Sub PastOrderInfo()
Was the problem. Needed to specify the workbook, so after adding:
Set wks = Workbooks("VBA - Final Project.xlsm").Worksheets("Order Data")
It worked!
I'm getting type mismatch error on Line "If Not LRow = Range("C65536").End(xlUp).Row = "" Then"
Private Sub DEDUPLICATE_Click()
Application.ScreenUpdating = False
Dim n As Long
Dim LRow As Long
If Not LRow = Range("C65536").End(xlUp).Row = "" Then
LRow = Range("C65536").End(xlUp).Row
For n = LRow To 6 Step -1
If Application.WorksheetFunction.CountIf(Range("C6:C" & n), Range("C" & n).Text) > 1 Then
Range("C" & n).EntireRow.Delete
End If
Next n
End If
This code should delete all duplicate entity excluding the empty rows. Tried to change the data type from Long to Variant but it deletes all rows including the empty ones.
Try this:
Private Sub DEDUPLICATE_Click()
Application.ScreenUpdating = False
Dim n As Long
Dim LRow As Long
LRow = Range("C65536").End(xlUp).Row
For n = LRow To 6 Step -1
If Application.WorksheetFunction.CountIf(Range("C6:C" & n), Range("C" & n).Text) > 1 Then
If Not Range("C" & n).Value = "" Then
Range("C" & n).EntireRow.Delete
End If
End If
Next n
End Sub
Its because the rows count is a numeric value and you are comparing it with a string
Private Sub DEDUPLICATE_Click()
Application.ScreenUpdating = False
Dim n As Long
Dim LRow As Long
If Not LRow = Range("C65536").End(xlUp).Row = 0 Then
LRow = Range("C65536").End(xlUp).Row
For n = LRow To 6 Step -1
If Application.WorksheetFunction.CountIf(Range("C6:C" & n), Range("C" & n).Text) > 1 Then
Range("C" & n).EntireRow.Delete
End If
Next n
End If
End Sub
Thanks
I'm just about finished writing this Sub for Excel. I'm basically asking my end user for a total (for example, $3000) find the total amount spent by each customer on the list and report those whose total is more than $3000 (the amount provided by the user) on a new worksheet that I created called Report.
I have this code written so far, which also validates the value entered by the user:
Sub Userinput()
Dim myValue As Variant
myValue = InputBox("Give me some input")
Range("E1").Value = myValue
If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
End Sub
Any suggestions on how I can use the inputted value to search through the customer data base and find more than what was inputted and place that in a new worksheet?
EDIT:
Data sample:
Customer orders
Order Date Customer ID Amount purchased
02-Jan-12 190 $580
02-Jan-12 144 $570
03-Jan-12 120 $1,911
03-Jan-12 192 $593
03-Jan-12 145 $332
try this
Sub Userinput()
Dim cl As Range, cl2 As Range, key, myValue
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
dic.comparemode = vbTextCompare
myValue = InputBox("Give me some input")
[E1].Value = "Amount Limit: " & myValue
If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
For Each cl In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
If Not dic.exists(cl.Value) Then
dic.Add cl.Value, Nothing
End If
Next cl
Set cl = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Set cl2 = Range("C2:C" & Cells(Rows.Count, "B").End(xlUp).Row)
[E2] = ""
For Each key In dic
If WorksheetFunction.SumIf(cl, key, cl2) > myValue Then
If [E2] = "" Then
[E2] = "Customer ID: " & key
Else
[E2] = [E2] & ";" & key
End If
End If
Next key
Set dic = Nothing
End Sub
output
update
Sub Userinput()
Dim cl As Range, cl2 As Range, key, myValue, i&
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
dic.comparemode = vbTextCompare
myValue = InputBox("Give me some input")
With Sheets("Source")
.[E1].Value = "Amount Limit: " & myValue
If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
myValue = CDec(myValue)
For Each cl In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
If Not dic.exists(cl.Value) Then
dic.Add cl.Value, Nothing
End If
Next cl
Set cl = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
Set cl2 = .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
Sheets("Destination").UsedRange.ClearContents
Sheets("Destination").[A1] = "Customer ID": i = 2
For Each key In dic
If WorksheetFunction.SumIf(cl, key, cl2) > myValue Then
Sheets("Destination").Cells(i, "A") = key: i = i + 1
End If
Next key
End With
Set dic = Nothing
End Sub
output
You may try this. I assume you need copied into worksheet in same workbook
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyOutputWorksheet As Worksheet
Sub Userinput()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("WorksheetName")
Set MyOutputWorksheet = MyWorkbook.Sheets("OutputWorksheetName")
Dim myValue As Long
Dim RowPointer As Long
myValue = InputBox("Give me some input")
MyWorksheet.Range("E1").Value = myValue
'conditional checking
If (Len(myValue) < 0 Or Not IsNumeric(myValue)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
For RowPointer = 2 To MyWorksheet.Cells(Rows.Count, "C").End(xlUp).Row
If MyWorksheet.Range("C" & RowPointer).Value > MyWorksheet.Range("E1").Value Then
MyWorksheet.Range(("A" & RowPointer) & ":C" & RowPointer).Copy Destination:=MyOutputWorksheet.UsedRange.Offset(1, 0)
'MyOutputWorksheet.UsedRange.Offset(1, 0).Value = MyWorksheet.Rows(RowPointer, 1).EntireRow.Value
End If
Next RowPointer
End Sub
Here is another approach which takes advantage of straight forward Excel features to Copy the customer IDs column, RemoveDuplicates, SUMIF based on customer, and Delete those rows over the minimum.
Sub CopyFilterAndCountIf()
Dim dbl_min As Double
dbl_min = InputBox("enter minimum search")
Dim sht_data As Worksheet
Dim sht_out As Worksheet
Set sht_data = ActiveSheet
Set sht_out = Worksheets.Add()
sht_data.Range("B:B").Copy sht_out.Range("A:A")
sht_out.Range("A:A").RemoveDuplicates 1, xlYes
Dim i As Integer
For i = sht_out.UsedRange.Rows.Count To 2 Step -1
If WorksheetFunction.SumIf( _
sht_data.Range("B:B"), sht_out.Cells(i, 1), sht_data.Range("C:C")) < dbl_min Then
sht_out.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
I don't do error checking on the input, but you can add that in. I am also taking advantage of Excel's willingness to process entire columns instead of dealing with finding ranges. Definitely makes it easier to understand the code.
It should also be mentioned that you can accomplish all of these same features by using a Pivot Table with a filter on the Sum and no VBA.
I am new to Excel VBA and I really need your help. I have a code that will look for the duplicate values in Column A. This code will highlight the duplicate values. I want:
1.) This code to ONLY run when I click on a button.
2.) I would like to have (somewhere in the same worksheet), the number of duplicate results and a hyper link that when you click on it will direct you the duplicate result (this is because I have sometimes huge files that I need to validate). Here is the code I currently have:
Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim C As Range, i As Long
If Not Intersect(Target, Me.[A:A]) Is Nothing Then
Application.EnableEvents = False
For Each C In Target
If C.Column = 1 And C.Value > "" Then
If WorksheetFunction.CountIf(Me.[A:A], C.Value) > 1 Then
i = C.Interior.ColorIndex
f = C.Font.ColorIndex
C.Interior.ColorIndex = 3 ' Red
C.Font.ColorIndex = 6 ' Yellow
C.Select
MsgBox "Duplicate Entry !", vbCritical, "Error"
C.Interior.ColorIndex = i
C.Font.ColorIndex = f
End If
End If
Next
Application.EnableEvents = True
End If
End Sub
I would really appreciate it if you help me with this.
Add the code to Module1 Alt+F11
Option Explicit
Sub MyButton()
Dim RangeCell As Range, _
MyData As Range
Dim MyDupList As String
Dim intMyCounter As Integer
Dim MyUniqueList As Object
Dim lngLastRow As Long, lngLoopRow As Long
Dim lngWriteRow As Long
Set MyData = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set MyUniqueList = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
MyDupList = "": intMyCounter = 0
'// Find Duplicate
For Each RangeCell In MyData
If RangeCell <> "V" And RangeCell <> "R" Then
If Evaluate("COUNTIF(" & MyData.Address & "," & RangeCell.Address & ")") > 1 Then
'// Color. Change to suit RGB(141, 180, 226).
RangeCell.Interior.Color = RGB(141, 255, 226)
If MyUniqueList.exists(CStr(RangeCell)) = False Then
intMyCounter = intMyCounter + 1
MyUniqueList.Add CStr(RangeCell), intMyCounter
If MyDupList = "" Then
MyDupList = RangeCell
Else
MyDupList = MyDupList & vbNewLine & RangeCell
End If
End If
Else
RangeCell.Interior.ColorIndex = xlNone
End If
End If
Next RangeCell
'// Move duplicate from Column 1 to Column 7 = (G:G)
lngWriteRow = 1
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lngLoopRow = lngLastRow To 1 Step -1
With Cells(lngLoopRow, 1)
If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), .Value) > 1 Then
If Range("G:G").Find(.Value, lookat:=xlWhole) Is Nothing Then
Cells(lngWriteRow, 7) = .Value
lngWriteRow = lngWriteRow + 1
End If
End If
End With
Next lngLoopRow
Set MyData = Nothing: Set MyUniqueList = Nothing
Application.ScreenUpdating = False
If MyDupList <> "" Then
MsgBox "Duplicate entries have been found:" & vbNewLine & MyDupList
Else
MsgBox "There were no duplicates found in " & MyData.Address
End If
End Sub
.
Add Module
Add Button
Assign to Macro