Posts by davesexcel

Sub GetData()
    Dim rng As Range, c As Range, LstRw As Long
    Set rng = Range("Q40:Q430").SpecialCells(xlCellTypeConstants, 23).Offset(, 5)
    Application.EnableEvents = False
    For Each c In rng.Cells
        If c <> "" Then
            LstRw = Cells(Rows.Count, "C").End(xlUp).Row + 1
            Cells(LstRw, "C") = c
            Cells(LstRw, "F") = c.Offset(, 3)
            Cells(LstRw, "K") = c.Offset(, 8)
            Cells(LstRw, "M") = c.Offset(, 10).Value
        End If
    Next
    Application.EnableEvents = True
End Sub

Private Sub TextBox1_Change()


Dim x
x = IIf(Me.TextBox2 = "", 0, Me.TextBox2)


TextBox3.Value = 250 - (TextBox1.Value - x)
End Sub




Private Sub TextBox2_Change()
Dim x, y
x = IIf(Me.TextBox2 = "", 0, Me.TextBox2)
y = IIf(Me.TextBox1 = "", 0, Me.TextBox1)
TextBox3.Value = 250 - (y - x)




End Sub

Private Sub CommandButton1_Click()
Dim LstRw As Long


 For x = 0 To ListBox1.ListCount - 1
      
      If ListBox1.Selected(x) = True Then
With Sheet2

.Cells(.Rows.Count, 1).End(xlUp).Offset(1) = ListBox1.List(x, 0)
.Cells(.Rows.Count, 2).End(xlUp).Offset(1) = ListBox1.List(x, 1)
End With
End If
   
   Next x
   Unload Me
            

End Sub

Private Sub ListBox1_Change()
    Dim LstRow As Long
    UserForm1.ListBox2.Clear

    UserForm1.ListBox2.AddItem Sheets("Sheet1").Cells(ListBox1.ListIndex + 2, 2)
    With Sheet2
        LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        .Cells(LstRow, 1) = Me.ListBox1
        .Cells(LstRow, 2) = Sheets("Sheet1").Cells(ListBox1.ListIndex + 2, 2)
    End With
End Sub

Private Sub CommandButton1_Click()
    Dim doc As Object, rng As Range
    Application.SendKeys "(%{1068})"
    DoEvents
    'ActiveSheet.Paste
    With CreateObject("Outlook.Application").CreateItem(0)
        .display
        Set doc = .GetInspector.WordEditor
        doc.Range(0, 0).Paste
        .To = "someone@somewhere.com"
        .Subject = "Send Email Body"
    End With
    
End Sub

Private Sub CommandButton1_Click()
    Dim wb As Workbook
    Dim sh As Worksheet, c As Range
    Dim rng As Range

    Set wb = Workbooks("Destination.xlsx")
    Set sh = wb.Sheets("Sheet2")
    With sh
        Set rng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        For Each c In rng.Cells
            If UCase(c) = UCase(Me.Range("D5").Value) Then
                If UCase(c.Offset(, 3)) = UCase(Me.Range("D7")) Then
                    If c.Offset(, 4) = Me.Range("D8") Then
                        c.Offset(, 9) = "Calibration done"
                        Exit For
                    End If
                End If
            End If
        Next c
    End With

End Sub

    Dim sh As Worksheet
    Dim rng As Range, c As Range

    Set sh = Sheets(1)
    With sh
        Set rng = .Range("L2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
        For Each c In rng.Cells
            If c <> "" Then
                With c
                    .NumberFormat = "@"
                    .Value = "000" & c
                End With
            End If
        Next
    End With

Sub PrintShts()
    Dim s As Long, x
    Dim sh As Worksheet

    Set sh = Sheets("Enter Data Here")

    With sh
        s = .Cells(.Rows.Count, "A").End(xlUp).Row - 5

        For x = 1 To s
            With Sheets("Item " & x)
                .Range("A5") = x
                .PrintPreview                    'change to printout
            End With
        Next
    End With

End Sub