Posts by Max1616

Max1616 · Apr 5th 2018

Hello! try this code:

Code

Sub Random_Names()
Dim NameColumn As Integer
Dim FirstNameRow As Integer
Dim NewColumn As Integer
Dim NumberOfNames As Integer
Dim lrow As Long
Dim StoredNames As String
Dim Counter As Integer
Dim Name As String


NameColumn = 1 'Change this if your names are not in column A
FirstNameRow = 2 'Change this if your first name does not start in row 2 (1 would be the column header)
NewColumn = 5 'Change this if you want to change the column of 10 names from column E to a different colulmn
NumberOfNames = 10 '10 Names in new list


lrow = Cells(Rows.Count, NameColumn).End(xlUp).Row
Counter = 2
StoredNames = ""


Cells(1, NewColumn) = "Random Name List (" & NumberOfNames & ")"
Range(Cells(2, NewColumn), Cells(NumberOfNames + 1, NewColumn)).ClearContents


Do Until Cells(NumberOfNames + 1, NewColumn) <> ""
    Name = WorksheetFunction.Index(Range(Cells(FirstNameRow, NameColumn), Cells(lrow, NameColumn)), WorksheetFunction.RandBetween(1, lrow - FirstNameRow + 1))
    If InStr(StoredNames, Name) = 0 Then
        StoredNames = StoredNames & " " & Name
        Cells(Counter, NewColumn) = Name
        Counter = Counter + 1
    End If
Loop




End Sub

Display More

You can change these variables per your specific needs:
NameColumn = 1 'Change this if your names are not in column A
FirstNameRow = 2 'Change this if your first name does not start in row 2 (1 would be the column header)
NewColumn = 5 'Change this if you want to change the column of 10 names from column E to a different colulmn
NumberOfNames = 10 '10 Names in new list

Let me know if you have any questions.

-Max

Max1616 · Apr 3rd 2018

Hello,

Place this code in the userform module (to access the userform module, double click anywhere on the user form in visual basic editor):

Code

Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = Sheets("Sheet2")


If Me.ComboBox1 = "" Then
    MsgBox "Please select a style name."
    Exit Sub
End If


Me.TextBox1 = WorksheetFunction.VLookup(Me.ComboBox1.Value, ws.Range("A:F"), 2, False)
Me.TextBox2 = WorksheetFunction.VLookup(Me.ComboBox1.Value, ws.Range("A:F"), 3, False)
Me.TextBox3 = WorksheetFunction.VLookup(Me.ComboBox1.Value, ws.Range("A:F"), 4, False)
Me.TextBox4 = WorksheetFunction.VLookup(Me.ComboBox1.Value, ws.Range("A:F"), 5, False)
Me.TextBox5 = WorksheetFunction.VLookup(Me.ComboBox1.Value, ws.Range("A:F"), 6, False)
End Sub


Private Sub CommandButton2_Click()
Unload Me
End Sub


Private Sub UserForm_Initialize()
Me.ComboBox1.Clear
Dim ws As Worksheet
Dim lrow As Long
Dim i As Long


Set ws = Sheets("Sheet2")
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row


For i = 2 To lrow
    Me.ComboBox1.AddItem ws.Cells(i, 1)
Next i


End Sub

Display More

I also noticed that your userform has the combo box's row source set to the range Sheet2!A2:A100. You will need to delete this before the above code will work. To do that follow these steps:
1. Go to the userform and pull up the properties window in visual basic editor.
2. Click on the combo box and the properties window should change to reflect the combo box
3. Within the properties window, scroll down to "RowSource" and delete the text in this field
4. Save and exit visual basic editor.

If you change your sheet names at any point in the future, you will need to update the text in the above code from "Sheets("Sheet2")" to "Sheets("NewSheetName")". This appears twice in the code I wrote for you.
Let me know if you have any questions.

Max1616 · Feb 12th 2018

Try changing mypath to B:\Stat\

Also, if other users in this shared location have this location mapped to a different drive than "B", your macro will fail. You should change mypath from B:\Srat\ to the actual address. Example: \\test.com\usrpub1\Stat\

Max1616 · Jan 29th 2018

I would do something like this:

Code

Private Sub Workbook_Open()
Dim i As Integer
Dim check As Integer


For i = 1 To Sheets.Count
    If Sheets(i).Name = Format(Now, "DDDD") Then
        Sheets(i).Activate
        check = 1
    End If
Next i
If check = 0 Then MsgBox ("Could not find sheet """ & Format(Now, "DDDD") & """")


End Sub

Display More

Max1616 · Dec 29th 2017

First you will need unlock the cells in the worksheet (re-lock any cells you would like to prevent people from editing):
Select all cells in the worksheet (Cntrl + A) -> Right Click the Cells and click "Format Cells" -> Protection Tab -> Uncheck the "Locked" box.

Then you can use this code. Anytime "Sanctioned" or "Rejected File" is selected in column F, and the user chooses yes on the input box, the entire row will be locked from editing:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim AnswerNum As Integer
Dim Answer As String
Dim Password As String


Password = "Password123"


If Not Intersect(Target, Range("F:F")) Is Nothing And Len(Target.Value) > 0 Then
    If Target.Value <> "Sanctioned" And Target.Value <> "Rejected file" Then GoTo Endsub
    AnswerNum = MsgBox("Would you like to change the status to " & Target.Value & "?", vbYesNo)
    If AnswerNum = 6 Then Answer = "Yes"
    If AnswerNum = 7 Then Answer = "No"


    If Answer = "Yes" Then
        'Code for Yes Answer
        ActiveSheet.Unprotect (Password)
        Target.EntireRow.Locked = True
        ActiveSheet.Protect (Password)
    End If


    If Answer = "No" Then
        'Code for No Answer
    End If
End If
Endsub:
End Sub

Display More

Please update the password in the code. It is currently "Password123"

Max1616 · Dec 29th 2017

Can you paste the formula in cell P2 that you want copied down?

Also, to confirm, if there is no data in column A you would like the same row in column P to be blank? And whenever someone enters something into a row in column A, that corresponding row in column P should be populated with the formula?

Max1616 · Dec 28th 2017

Oh I forgot to mention, place this in the worksheet module for the worksheet that is being edited.

Max1616 · Dec 28th 2017

Hello,

Try this:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim AnswerNum As Integer
Dim Answer As String


If Not Intersect(Target, Range("F:F")) Is Nothing And Len(Target.Value) > 0 Then
    AnswerNum = MsgBox("Would you like to change the status to " & Target.Value & "?", vbYesNo)
    If AnswerNum = 6 Then Answer = "Yes"
    If AnswerNum = 7 Then Answer = "No"


    If Answer = "Yes" Then
        'Code for Yes Answer
    End If


    If Answer = "No" Then
        'Code for No Answer
    End If
End If


End Sub

Display More

Update the code where indicated, to do whatever you want when they select Yes/No

Max1616 · Dec 27th 2017

Also, I think your count formula is wrong. I am showing 15 instances of 7 day consecutive positive returns. You might just want to count column L since the macro provides the dates for each run.

Max1616 · Dec 27th 2017

Try this:

Code

Sub ConsecutiveDates()
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long
Dim counter As Integer


lrow1 = Cells(Rows.Count, 1).End(xlUp).Row 'Last row for loop


For i = 2 To lrow1
    If Cells(i, 8) > 0 Then counter = counter + 1
    If Cells(i, 8) <= 0 Then counter = 0
    If counter = 7 Then
        lrow2 = Cells(Rows.Count, 12).End(xlUp).Row + 1 'Row to place the date (12 signifies column L)
        Cells(lrow2, 12) = Cells(i, 1)
        Cells(lrow2, 12).NumberFormat = "mm/dd/yyyy"
        counter = 0
    End If
Next i
End Sub

Display More

Let me know if it works for you!

Max1616 · Dec 8th 2017

Use this event:

Code

Private Sub ComboBox1_AfterUpdate()

Max1616 · Nov 28th 2017

Try this:

Code

Sub PriceFill()


Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim e As Long
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim counter As Long
Dim addition As Double


counter = 1


a = Range("A1").End(xlDown).Row
b = Range("B1").End(xlDown).Row
c = Range("C1").End(xlDown).Row
d = Range("D1").End(xlDown).Row
e = Range("E1").End(xlDown).Row


For i1 = 2 To a
    For i2 = 2 To b
        For i3 = 2 To c
            For i4 = 2 To d
                For i5 = 2 To e


                If i3 = 10 Then addition = Cells(i2, 18) 'C10
                If i3 = 11 Then addition = Cells(i2, 21) 'C11
                If i3 = 12 Then addition = Cells(i2, 24) 'C12


                Cells(counter, 10) = Cells(i1, 1) + Cells(i2, 2) + Cells(i3, 3) + Cells(i4, 4) + Cells(i5, 5) + addition
                counter = counter + 1
Nexti:
                addition = 0
                Next i5
            Next i4
        Next i3
    Next i2
Next i1




End Sub

Display More

Max1616 · Aug 28th 2017

Re: Subtract cell value based on textbox

Hello! Create a command button for your user form (to run the code when clicked) and then paste in this code to the userform module:

Code

Private Sub CommandButton1_Click()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim lrow As Long
Dim frow As Long
Dim MType As String
Dim MSize As String
Dim MInv As String
Dim MDate As Date
Dim MAmount As Double
Dim MCustomer As String


Set ws1 = Sheets("Inventory")
Set ws2 = Sheets("Data")


MDate = TextBox1
MCustomer = TextBox2
MAmount = TextBox3


frow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1


For i = 1 To Me.ListBox1.ListCount
    lrow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    If ListBox1.Selected(i - 1) Then
        MType = ListBox1.List(i - 1, 0)
        MSize = ListBox1.List(i - 1, 1)
        MInv = ListBox1.List(i - 1, 2)
        ws2.Cells(lrow, 1) = MDate
        ws2.Cells(lrow, 2) = MCustomer
        ws2.Cells(lrow, 3) = MType
        ws2.Cells(lrow, 4) = MSize
        ws2.Cells(lrow, 5) = MAmount
    End If
Next i


For i = frow To lrow
    For j = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
        If ws1.Cells(j, 1) = ws2.Cells(i, 3) And ws1.Cells(j, 2) = ws2.Cells(i, 4) Then
            ws1.Cells(j, 3) = ws1.Cells(j, 3) - ws2.Cells(i, 5)
            If ws1.Cells(j, 3) <= 0 Then MsgBox ("This entry will cause " & ws1.Cells(j, 1) & " size " & ws1.Cells(j, 2) & " to be at " & ws1.Cells(j, 3) & " inventory.")
        End If
    Next j
Next i


Unload Me
End Sub

Display More

I hope this helps!

-Max

Max1616 · Aug 28th 2017

Re: vba to transpose rows headers and data to columns headers with respective data

Hello! Give this a try:

Code

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim SheetName As String
Dim lrow As Long
Dim pg As String
Dim i As Long
Dim Counter As Long
Dim pgCounter As Long


Set ws1 = ActiveSheet
SheetName = "Test"


Application.DisplayAlerts = False
On Error Resume Next
Sheets(SheetName).Delete
Application.DisplayAlerts = True


Set ws2 = Sheets.Add
ws2.Name = SheetName


ws2.Cells(1, 1) = "Page"
ws2.Cells(1, 2) = ws1.Cells(8, 1)
ws2.Cells(1, 3) = ws1.Cells(9, 1)
lrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row


Counter = 2
pgCounter = 2


For i = 10 To lrow Step 2


    ws2.Cells(Counter, 2) = ws1.Cells(i, 1)
    ws2.Cells(Counter, 3) = ws1.Cells(i + 1, 1)


    If InStr(ws1.Cells(i, 1), "Page") > 0 Then
        pg = Right(ws1.Cells(i, 1), 1)
        ws2.Range(ws2.Cells(pgCounter, 1), Cells(Counter, 1)) = pg
        pgCounter = Counter
        i = i + 4
        Counter = Counter - 1
    End If


    Counter = Counter + 1
Next i


End Sub

Display More

Max1616 · Aug 21st 2017

Re: VBA - ToggleButton Hide/Unhide Rows

Try this:

Code

Sub HideRows()


Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim lrow1 As Long
Dim CheckRow As Long
Dim i As Long
Dim mRow As Long




Set ws1 = Sheets("Compare")
Set ws2 = Sheets("Control")
Set ws3 = Sheets("Live")


lrow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
CheckRow = 7 'Row which you want to start checking in ws1 (Compare)


For i = CheckRow To lrow1
    If ws1.Cells(i, 2) = 0 Then
        On Error Resume Next
        If WorksheetFunction.Match(ws1.Cells(i, 1), ws2.Columns(4), 0) > 0 And WorksheetFunction.Match(ws1.Cells(i, 1), ws3.Columns(4), 0) > 0 Then
            ws2.Rows(WorksheetFunction.Match(ws1.Cells(i, 1), ws2.Columns(4), 0)).Hidden = True
            ws3.Rows(WorksheetFunction.Match(ws1.Cells(i, 1), ws3.Columns(4), 0)).Hidden = True
        End If
    End If
Next i
      
End Sub


Sub UnhdieRows()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet


Set ws1 = ActiveSheet
Set ws2 = Sheets("Control")
Set ws3 = Sheets("Live")


ws2.Range(ws2.Rows(1), ws2.Rows(ws2.Cells(Rows.Count, 4).End(xlUp).Row)).Hidden = False
ws3.Range(ws3.Rows(1), ws3.Rows(ws3.Cells(Rows.Count, 4).End(xlUp).Row)).Hidden = False


End Sub

Display More

You can assign the code to a toggle button. (Let me know if you need help doing that). There are two macros here, one to hide all the rows that meet your criteria, and another to unhide all rows.

Let me know how it works!

Max1616 · Jul 28th 2017

Re: Delete Entire Rows from raw source Sheet that selected from ListBox and Auto Refr

Hi Luzmen,

This is because a listbox index starts at 0. So if you have a list that corresponded to rows 1-10. When the item in row 10 is selected, the list box index is 9 (full list index is 0-9).

My guess is your index starts in row 2, so in this case row 2 = listbox.listindexindex 0

Lets use a hypothetical:

If your listbox contains values starting in row 2 to row 15 (2:15), your index for this list looks like this:
0 = Row 2
1 = Row 3
2 = Row 4
3 = Row 5
etc.
.
.
11 = Row 15

So if you wanted to delete the row 10, you would need to set your list box to the row 10 value (Which in this case is index then use Rows(ListBox.ListIndex + 2) since your index and row values are two digits off.

I hope this makes sense and answers your question!

Sincerely,
Max

Max1616 · Jul 27th 2017

Re: Delete Entire Rows from raw source Sheet that selected from ListBox and Auto Refr

Have you tried putting the sheet name where the listbox lives in front of the listbox?

Sheets("ListBoxSheetName").ListBox1.ListFillRange = "a:a"

Max1616 · Jun 23rd 2017

Re: VBA - if cell value true, offset, check value then delete if criteria met

Awesome! Glad it works!

Max1616 · Jun 20th 2017

Re: VBA - if cell value true, offset, check value then delete if criteria met

Try this:

Code

Sub work_filter()


Dim i As Long
Dim j As Long
Dim lrow As Long


lrow = Cells(Rows.Count, 6).End(xlUp).Row


For i = lrow To 2 Step -1
    If Cells(i, 6) = "LON" Then
        For j = i To lrow
            If Cells(j, 6) = "AVAIL" Or Cells(j, 6) = "ENROUTE" Then
                Cells(j, 6).EntireRow.Delete
                j = j - 1
            End If
            
            If Cells(j, 6) = "ONJOB" Then GoTo Nexti
            
        Next j
    End If
Nexti:
Next i
End Sub

Display More

If this is wrong, can you send me a list before and after the macro is ran?

Max1616 · Jun 20th 2017

Re: VBA - if cell value true, offset, check value then delete if criteria met

Can you send me a list of what the following would look like after the macro is ran:
Column F
LON
AVAIL
JOB
ENROUTE
LOF
LON
ENROUTE
AVAIL
JOB
ENROUTE
LOF
LON
BLAH

Posts by Max1616

Random select names from a list (w/some duplicates) to a new list without duplicates

Data Populating by combobox data

Vba code doesnt work on shared/group/network Drive

Choose Day Of The Week

VBA confirm dialog box if in column F cell value is "Sanctioned" or "Rejected file"

VBA (Macro) auto fill down if column A is not blank.

VBA confirm dialog box if in column F cell value is "Sanctioned" or "Rejected file"

VBA confirm dialog box if in column F cell value is "Sanctioned" or "Rejected file"

Excel Challenge - Macro to Return a Date

Excel Challenge - Macro to Return a Date

Combobox change event if type

Add 'static' value into For Loop

Subtract cell value based on textbox

vba to transpose rows headers and data to columns headers with respective data

VBA - ToggleButton Hide/Unhide Rows

Delete Entire Rows from raw source Sheet that selected from ListBox and Auto Refresh

Delete Entire Rows from raw source Sheet that selected from ListBox and Auto Refresh

VBA - if cell value true, offset, check value then delete if criteria met

VBA - if cell value true, offset, check value then delete if criteria met

VBA - if cell value true, offset, check value then delete if criteria met