Posts by tmpollard

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long
    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If
    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If
    On Error GoTo SomethingWrong
    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")
    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1
    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then
        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If
    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If
    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub
SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0
End Sub
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function Array_Sort(ArrayList As Variant) As Variant
    Dim aCnt As Integer, bCnt As Integer
    Dim tempStr As String
    For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
        For bCnt = aCnt + 1 To UBound(ArrayList)
            If ArrayList(aCnt) > ArrayList(bCnt) Then
                tempStr = ArrayList(bCnt)
                ArrayList(bCnt) = ArrayList(aCnt)
                ArrayList(aCnt) = tempStr
            End If
        Next bCnt
    Next aCnt
    Array_Sort = ArrayList
End Function

Private Sub WorkSheet_Change(ByVal Target As Range)
    Dim x As Range, y As Long
    If Not Intersect(Target, Range("C:D,H:I,M:N,R:S")) Is Nothing Then
         
        Select Case Target.Column
        Case Is = 4, 9, 14, 19
            y = Cells(Rows.Count, Target.Column).End(3).Row
            For Each x In Range(Cells(2, Target.Column), Cells(y, Target.Column))
                If x.Value <> "" And x.Offset(, -1) <> "" Then
                    x.Offset(, -2) = x / x.Offset(, -1)
                Else
                    x.Offset(, -2) = ""
                End If
            Next x
        Case Is = 3, 8, 13, 18
            y = Cells(Rows.Count, Target.Column).End(3).Row
            For Each x In Range(Cells(2, Target.Column), Cells(y, Target.Column))
                If x.Value <> "" And x.Offset(, 1) <> "" Then
                    x.Offset(, -1) = x.Offset(, 1) / x
                Else
                    x.Offset(, -1) = ""
                End If
            Next x
        End Select
    End If
End Sub

Private Sub WorkSheet_Change(ByVal Target As Range)
Dim x As Range, y As Long
If Not Intersect(Target, Columns("C:D")) Is Nothing Then
    Select Case Target.Column
    Case Is = 4
    y = Cells(Rows.Count, 4).End(3).Row
        For Each x In Range(Cells(2, 4), Cells(y, 4))
            If x.Value <> "" And x.Offset(, -1) <> "" Then
                x.Offset(, -2) = x / x.Offset(, -1)
            Else
                x.Offset(, -2) = ""
            End If
        Next x
    Case Is = 3
    y = Cells(Rows.Count, 3).End(3).Row
        For Each x In Range(Cells(2, 3), Cells(y, 3))
            If x.Value <> "" And x.Offset(, 1) <> "" Then
                x.Offset(, -1) = x.Offset(, 1) / x
            Else
                x.Offset(, -1) = ""
            End If
        Next x
    End Select
End If
End Sub

Range("O2").Select
    ActiveCell.FormulaR1C1 = _
        =IFERROR(INDEX({"Machine 1","Machine 2","Machine 3"},MATCH(LEFT(A2,4),{"5000","5001","5002"},0)),"")
    Selection.NumberFormat = "0"
    Range("O2").Select
    Selection.Copy
    Range("N3").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False