Posts by Luke M

Private Sub Workbook_Open()Dim lastRow As Long
Dim expDate As Date
Dim i As Long




Application.ScreenUpdating = False




'Change sheet name to suit
With Worksheets("Sheet1")
    'Find last used row
    lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
    'Detemine date 6 months ago
    expDate = WorksheetFunction.EDate(Date, -6)
    
    For i = lastRow To 2 Step -1
        'If date is older than expiration date...
        If .Cells(i, "G").Value < expDate Then
            'delete the row
            .Rows(i).Delete
        End If
    Next i
End With




Application.ScreenUpdating = True




End Sub

Option Explicit
Dim newPerson As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fCell As Range
Dim myComp As String




Application.EnableEvents = False
If Not (Intersect(Target, Range("E11")) Is Nothing) Then
    'Name entered
    newPerson = False
    Set fCell = Worksheets("Companies").Cells.Find(Target.Value)
    
    If fCell Is Nothing Then
        newPerson = True
        Me.Range("G11").ClearContents
    Else
        myComp = Worksheets("Companies").Cells(1, fCell.Column).Value
        Range("G11") = myComp
    End If
    
ElseIf Not (Intersect(Target, Range("G11")) Is Nothing) Then
    'Company entered
    If newPerson Then
        With Worksheets("Companies")
            Set fCell = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 2)
            fCell.Value = Target.Value
            fCell.Offset(1, 0).Value = Me.Range("E11").Value
        End With
        newPerson = False
    End If
End If




Application.EnableEvents = True




End Sub

Option Explicit




Private Sub Worksheet_Change(ByVal Target As Range)
'Check if this is a cell we care about
If Intersect(Target, Range("K:K")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub




Dim xValue As Variant




If UCase(Target.Value) = "OTHER" Then
    'Not sure which cell you wanted to modify. Assuming it's in same row


    xValue = InputBox("What do you want to fill in cell L" & Target.Row & "?", "Other")
    'Turn off events since we're about to make a change
    Application.EnableEvents = False
    Me.Cells(Target.Row, "L").Value = xValue
    Application.EnableEvents = True
End If




End Sub

Option Explicit


Sub PasteData()
Dim fCell As Range
Dim fRow As Long




'Search for our value. If not found,
'fCell will be Nothing
On Error Resume Next
Set fCell = Range("A:A").Find(Me.TextBox1.Value)
On Error GoTo 0




'Check in case the value is not found
If Not fCell Is Nothing Then
    'What row is our cell in?
    fRow = fCell.Row
    
    'Transfer data from UserForm
    With Me
        Cells(fRow, "B").Value = .TextBox2
        Cells(fRow, "C").Value = .TextBox3
        Cells(fRow, "D").Value = .TextBox4
        Cells(fRow, "E").Value = .TextBox5
        'etc.
        
    End With
End If
End Sub

Option Explicit
Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim xShape As Shape
    For Each ws In ThisWorkbook.Worksheets
        For Each xShape In ws.Shapes
            If xShape.Type = msoFormControl Then
                xShape.ControlFormat.Value = Unchecked
                
            End If
        Next
    Next
End Sub
 
 
Private Sub CommandButton2_Click()
    Dim ws As Worksheet
    Dim xShape As Shape
    For Each ws In ThisWorkbook.Worksheets
        For Each xShape In ws.Shapes
            If xShape.Type = msoFormControl Then
                xShape.ControlFormat.Value = Checked
            End If
        Next
    Next
End Sub

Option Explicit




Sub Dynamic_Range_Test()




Dim lastRow As Long
With ActiveSheet
'Find the last used cell in col H
    lastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
    'Change the value of entire range, all at once
    .Range(.Range("A12").End(xlDown).Offset(1, 0), _
        .Cells(lastRow, "A")).Value = 20703
End With




End Sub

Sub FindCol()
Dim xCol As Long
Dim myVal As String
Dim cell As Range




'What are we looking for? The line break is character 10
myVal = Chr(10)
With ActiveSheet
    'Find our value and return the column
    xCol = .UsedRange.Find(myVal).Column
    'For test purposes
    MsgBox xCol
    
    For Each cell In .Range(.Cells(1, xCol), .Cells(2, xCol).End(xlDown))
        '....
        'continue code
    Next




End With
End Sub

Option Explicit
Public WithEvents MyButton As MSForms.CommandButton




Private Sub MyButton_Click()
Dim calledName as String
calledName = MyButton.Name
MsgBox calledName
End Sub

Dim TheCommandButtons() As New cButton




Sub ActivateActiveXCommandButtons()
  Dim sh As Shape
  Dim iButtonCount As Long




  ReDim TheCommandButtons(1 To 1)




  iButtonCount = 0
  For Each sh In ActiveSheet.Shapes
    If sh.OLEFormat.Object.OLEType = xlOLEControl Then
      iButtonCount = iButtonCount + 1
      ReDim Preserve TheCommandButtons(1 To iButtonCount)
      Set TheCommandButtons(iButtonCount).MyButton = sh.OLEFormat.Object.Object
    End If
  Next
End Sub




Sub DeactivateActiveXCommandButtons()
  Dim i As Long




  On Error Resume Next
  For i = LBound(TheCommandButtons) To UBound(TheCommandButtons)
    Set TheCommandButtons(i).MyButton = Nothing
  Next
End Sub