Posts by pike

Option Explicit
Sub ConvertTextToNumber()
    Const Title As String = "MSG Box"
    'error handling if Msgbox is cancelled or Esc
    On Error GoTo ErrorHandler:
    With Application.InputBox("Input Range", Title, Type:=8)
        .NumberFormat = "0.00"
    End With
    Exit Sub
ErrorHandler:
End Sub

Sub GetNumberCollection()
    Dim txt As String, mytxt As String
    Dim j As Variant, i As Long

    txt = "19603"
    With New Collection
        For Each j In Split(StrConv("0123456789", 64), Chr(0))
            .Add j, j
        Next
        For Each j In Split(StrConv(txt, 64), Chr(0))
            .Remove j
        Next
        For i = 1 To .Count
            mytxt = mytxt + .Item(i)
        Next
    End With

    MsgBox mytxt

End Sub

option explicit
Sub GetNumberOther()
    Dim txt As String, mytxt As String
    Dim i As Variant, j As Long
    Dim blnHook As Boolean
    txt = "03619"
    For j = 0 To 9
        For Each i In Split(StrConv(txt, 64), Chr(0))
            If i = j Then
                blnHook = True
            End If
        Next i
        If Not blnHook Then
            mytxt = mytxt & j
        End If
        blnHook = False
    Next j
    MsgBox mytxt
End Sub

Option Explicit
Sub testthree()
    Dim ws As Worksheet, ws2 As Worksheet, k As Long, xcell As Variant
    Dim db()
    Dim bln As Boolean
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    If Not Evaluate("IsError('NewSheet'!A1)") Then Sheets("NewSheet").Delete

    k = 1
    Sheets.Add.Name = "NewSheet"
    Set ws = Worksheets("Details for we 200522")
    Set ws2 = Worksheets("NewSheet")

    With ws
        ReDim db(1 To Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)).Count, 1 To 2)

        For Each xcell In Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants))
            Select Case True
            Case xcell.Value Like "Invoice :"
                If xcell.Offset(, 1).Value Like "33*" Then
                    db(k, 1) = Split(xcell.Offset(, 1).Value, " ")(0)
                    k = k + 1
                    bln = True
                Else
                    bln = False
                End If
            Case xcell.Value Like "UK*" And bln
                db(k, 1) = xcell.Value
                db(k, 2) = xcell.Offset(, 8).Value
                k = k + 1
            Case Else
            End Select
        Next xcell
    End With

    ws2.Range("A1").Resize(k, 2) = db

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Option Explicit
Sub testtwo()
    Dim ws, ws2 As Worksheet, k As Long, xcell As Variant
    Dim db()
    Dim strDate As String, strJob As String, strInvoice As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error Resume Next
    Sheets("NewSheet").Delete
    k = 1
    Sheets.Add.Name = "NewSheet"
    Set ws = Worksheets("Details for we 200522")
    Set ws2 = Worksheets("NewSheet")
    With ws
        
        ReDim db(Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)).Count, 6)
        
        For Each xcell In Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants))
            
          Select Case True
            Case xcell.Value Like "Date :"
                strDate = xcell.Offset(, 1).Value
            Case xcell.Value Like "Job :"
                strJob = xcell.Offset(, 1).Value
            Case xcell.Value Like "Invoice :"
                strInvoice = xcell.Offset(, 1).Value
            Case xcell.Value Like "UK*"
                db(k, 0) = strDate
                db(k, 1) = strJob
                db(k, 2) = strInvoice
                db(k, 3) = xcell.Value
                db(k, 4) = xcell.Offset(, 8).Value
                db(k, 5) = xcell.Offset(, 9).Value
            k = k + 1
            Case Else
          End Select
        
        Next xcell
       
       End With
        
        ws2.Range("A1").Resize(k, 6) = db

        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End Sub

Sub test()
Dim dbArray() As Variant
  
  With Sheet1
     .[a1:j14].ClearContents
     
     '1D array string conversion
    dbArray = [{1,2,3}]
     .Range("A1").Resize(1, UBound(dbArray)).Value = dbArray
     
    dbArray = [{"apple","bannana","mango"}]
     .Range("H1").Resize(1, UBound(dbArray)).Value = dbArray
     
     '2D array string conversion
    dbArray = [{1,2;3,4;5,6}]
     .Range("A5").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray

    dbArray = [{1,"apple";3,"bannana";5,"mango"}]
     .Range("H5").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray
          
    dbArray = [{1,2,3;4,5,6;7,8,9}]
     .Range("A10").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray
 
     '2D array string conversion with a string variable
    dbArray = Evaluate("{1,2;3,4;5,6}") 'have to be more explicit, the shorthand won't work
     .Range("E1").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray
     
     y = "{1,2;3,4;5,6}"
    dbArray = Evaluate(y) 'have to be more explicit, the shorthand won't work
     .Range("E5").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray
  
  '2D array string conversion with a string variable
  '  dbArray = Evaluate("1,apple;3,bannana;5,mango}") 'have to be more explicit, the shorthand won't work
  '  Range("E10").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray
  '  y = "{1,apple;3,bannana;5,mango}"
   ' dbArray = Evaluate(y) 'have to be more explicit, the shorthand won't work
   ' Range("E15").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray
  End With
  
End Sub

Sub test()
   Dim dbArray, myrow As Long
    myrow = 5
    With Sheet1
        dbArray = .Range("A1:I20").Value ' dummy data set
       With .[K1:S20]
          .ClearContents
          .Borders.LineStyle = xlNone
       End With
       With .Range("K3").Resize(3, 9)
          .Value2 = Application.Index(dbArray, Evaluate("ROW(3:" & myrow & ")"), Application.Transpose([row(1:9)]))
          .Borders.Weight = 2
       End With
       With .[L7].Resize(4, 7)
         .Value2 = Application.Index(dbArray, [Row(7:11)], Application.Transpose([row(2:8)]))
         .Borders.Weight = 2
       End With
       With .Range("N16").Resize(5, 6)
        .Value2 = Application.Index(dbArray, Evaluate("ROW(16:20)"), Application.Transpose([row(4:9)]))
        .Borders.Weight = 2
       End With
    End With
    
 '   With result = MsgBox("Table Count :" & myrow, vbOKCancel, "Table Count")
  '      With Results = InputBox("Table Count :" & myrow, vbOKCancel, "Table Count")
  '  MsgBox Results
  '  End With
  '  End With
    
End Sub

Option Explicit
Sub ImportLPileTextFile()
    Dim myFile As String, txtLine As String, blnCopy As Boolean, nRow As Long, eCol As Long, iCount As Long
    myFile = Application.GetOpenFilename()
    eCol = -2
    Open myFile For Input As #1
    Do Until EOF(1)
        Line Input #1, txtLine
        If txtLine Like "   y, inches         p, lbs/in   " Then
            blnCopy = True
            eCol = eCol + 3
            iCount = 1
        ElseIf Len(txtLine) < 1 Then
            blnCopy = False
            nRow = 1
            iCount = 0
        Else
            iCount = iCount + 1
        End If
        If blnCopy And iCount > 2 Then
           Sheet1.Cells(nRow, eCol).Value = Trim(Right(txtLine, 16))
           Sheet1.Cells(nRow, eCol + 1).Value = Trim(Left(txtLine, 16))
           nRow = nRow + 1
        End If
    Loop
    Close #1
    MsgBox "Table Count :" & (eCol + 2) / 3, vbInformation, "Table Count"
End Sub

Option Explicit
Sub ImportLPileTextFile()
    Dim myFile As String, txtLine As String, blnCopy As Boolean, n As Long, e As Long

    myFile = Application.GetOpenFilename()
    e = 1
    Open myFile For Input As #1

    Do Until EOF(1)
        Line Input #1, txtLine
        If txtLine Like "   y, inches         p, lbs/in   " Then
            blnCopy = True
            e = e + 3
        ElseIf Len(txtLine) < 1 Then
            blnCopy = False
            n = 1
        End If

        If blnCopy Then
            n = n + 1
            Cells(n, e - 2).Value = Trim(Right(txtLine, 18))
            Cells(n, e - 3).Value = Trim(Left(txtLine, 18))
        End If

    Loop
    Close #1
    MsgBox "Table Count :" & (e - 1) / 3, vbInformation, "Table Count"
End Sub

Option Explicit
Sub testshet()
    Dim a, b(), i As Long, n As Long, dic1, w, e As Long
    With Range("a1").CurrentRegion
        a = .Resize(, 3).Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) * 2)
    End With
    Set dic1 = CreateObject("Scripting.Dictionary")
    dic1.CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If Not dic1.Exists(a(i, 1)) Then
            n = n + 1
            dic1.Add a(i, 1), Array(n, 2)
            b(n, 1) = a(i, 1)
            b(n, 2) = a(i, 2)
            b(n, 3) = a(i, 3)
        Else
            w = dic1(a(i, 1))
            w(1) = w(1) + 2
            b(w(0), w(1)) = a(i, 2)
            b(w(0), w(1) + 1) = a(i, 3)
              e = Application.Max(w(1), e)
            dic1(a(i, 1)) = w
        End If
    Next
    Range("e1").Resize(n, e + 1).Value = b
End Sub

Option Explicit
Sub testi()
    Dim a(), b(), i As Long, n As Long, t As Long, w, e, u
    Dim dic1 As Object, dic2 As Object
    Set dic1 = CreateObject("Scripting.Dictionary")
    dic1.CompareMode = vbTextCompare
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic2.CompareMode = vbTextCompare
    With Sheet3
        a = .Range("a1").CurrentRegion.Resize(, 7).Value
    End With
    n = 1
    t = 1
    ReDim b(1 To UBound(a, 1), 1 To 14)
    For i = 2 To UBound(a, 1)
        If Not dic1.exists(Format(a(i, 1), "mmmm")) Then
            t = t + 1
            dic1.Add Format(a(i, 1), "mmmm"), Array(t, a(i, 7))
            b(1, t) = Format(a(i, 1), "mmmm")
        Else
            w = dic1(Format(a(i, 1), "mmmm"))
            w(1) = w(1) + a(i, 7)
            dic1(Format(a(i, 1), "mmmm")) = w
        End If
        If Not dic2.exists(a(i, 4)) Then
            n = n + 1
            dic2.Add a(i, 4), Array(n, a(i, 7))
            b(n, 1) = a(i, 4)
        Else
            u = dic2(a(i, 4))
            u(1) = u(1) + a(i, 7)
            dic2(a(i, 4)) = u
        End If
        b(dic2(a(i, 4))(0), dic1(Format(a(i, 1), "mmmm"))(0)) = b(dic2(a(i, 4))(0), dic1(Format(a(i, 1), "mmmm"))(0)) + a(i, 7)
    Next
    For Each e In dic1.keys
        w = dic1.Item(e)
        b(n + 1, w(0)) = w(1)
        b(n + 1, t + 1) = b(n + 1, t + 1) + w(1)
    Next
    For Each e In dic2.keys
        u = dic2.Item(e)
        b(u(0), t + 1) = u(1)
    Next
    With Sheet2
        .UsedRange.Clear
        With .Range("a1").Resize(n + 1, t + 1)
            .Value = b
            .Borders.Weight = 2
        End With
    End With
End Sub

Option Explicit
Dim PrevCell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not PrevCell Is Nothing Then
        With PrevCell
            .Font.Bold = False
            'PrevCell.BorderAround LineStyle:=xlNone, Weight:=xlThin, ColorIndex:=xlNone
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            .Borders(xlEdgeBottom).LineStyle = xlNone
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
    End If
    With Target
        .Font.Bold = True
        .BorderAround ColorIndex:=5, Weight:=xlThick
    End With
    'Target.Borders.LineStyle = Excel.XlLineStyle.xlLineStyleNone
    Set PrevCell = Target
End Sub