Posts by jindon

jindon · Oct 24th 2015

Re: select row and chane fonts with VBA

1) No need to "Select".
2) Variables for Row counter should be Long type.

try

Code

Sub b()
    Dim i3 As Long
    Dim LR3 As Long
    With Sheets("sheet1")
        LR3 = .Range("A" & Rows.Count).End(xlUp).Row
        For i3 = 6 To LR3
            If .Cells(i3, 1).Value = "" Then
                With .Cells(i3, 1).EntireRow.Range("d1,q1")
                    .Font.Bold = True
                    .RowHeight = 20
                    .VerticalAlignment = xlTop
                End With
            End If
        Next
    End With
End Sub

Display More

jindon · Oct 24th 2015

Re: How do I automate to select particular columns from the mastersheet to another sh

Upload a file that has same format as your actual file.

jindon · Oct 23rd 2015

Re: How do I automate to select particular columns from the mastersheet to another sh

Try

Code

Sub test()
    Dim a, i As Long, ii As Long, n As Long, dic As Object
    Dim sDate As Date, eDate As Date, temp As Date, myTbl As ListObject
    Const myStyle As String = "TableStyleMedium9"
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("sheet1").Cells(1).CurrentRegion
        sDate = Application.Min(.Columns(2))
        sDate = sDate - Day(sDate) + 1
        eDate = Application.Max(.Columns(2))
        eDate = eDate - Day(eDate) + 1
        a = .Value
    End With
    Do
        temp = DateAdd("m", n, sDate)
        Set dic(Format$(temp, "mmmm, yyyy")) = _
        CreateObject("System.Collections.ArrayList")
        n = n + 1
    Loop While temp < eDate
    For i = 2 To UBound(a, 1)
        a(i, 2) = Format$(a(i, 2), "mmmm, yyyy")
        dic(a(i, 2)).Add _
        Join(Array(a(i, 1), Format$(a(i, 2), "mm/dd/yyyy")), " - ")
    Next
    With Sheets("OutPut")
        .Cells.Delete
        With .Cells(1).Resize(, dic.Count)
            .Value = dic.keys
            For ii = 1 To .Columns.Count
                If dic(.Cells(1, ii).Value).Count > 0 Then
                    .Cells(2, ii).Resize(dic(.Cells(1, ii).Value).Count).Value = _
                    Application.Transpose(dic(.Cells(1, ii).Value).ToArray)
                End If
            Next
        End With
        With .Cells(1).CurrentRegion
            .Rows(1).Font.Size = 12
            Set myTbl = .Parent.ListObjects.Add(1, .Cells, , 1)
            myTbl.TableStyle = myStyle
            myTbl.ShowAutoFilter = False
            .RowHeight = 40.25
            .VerticalAlignment = xlTop
            .HorizontalAlignment = xlCenter
            .Columns.AutoFit
        End With
        .Select
    End With
End Sub

Display More

jindon · Oct 22nd 2015

Re: consolidate rows into single row

Add one line

Code

With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 5)
        .Parent.AutoFilterMode = False  '<----------------------------
        a = .Value: ReDim w(1 To UBound(a, 2))

jindon · Oct 22nd 2015

Re: VBA - first to match Name with data range and perform Hlookup

1)

Code

a = Sheets("sheet2").[a1].CurrentRegion.Value

2)

Code

With Sheets("sheet1").[a3].CurrentRegion

jindon · Oct 22nd 2015

Re: consolidate rows into single row

You should keep remain "VSortM" sub procedure intact, don't delete it.

jindon · Oct 21st 2015

Re: consolidate rows into single row

Confusing...
try

Code

Sub MOformat()
     'combines in and out times onto single row for format and reporting
    Dim a, i As Long, ii As Long, e, w, n As Long
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 5)
        a = .Value: ReDim w(1 To UBound(a, 2))
        VSortM a, 2, UBound(a, 1), 4, 1
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 4) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2), 1 To 1)
                    Else
                        w = .Item(a(i, 1))
                        ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii, UBound(w, 2)) = a(i, ii)
                    Next
                    .Item(a(i, 1)) = w
                ElseIf a(i, 5) <> "" Then
                    If .exists(a(i, 1)) Then
                        w = .Item(a(i, 1))
                        For ii = 1 To UBound(w, 2)
                            If w(5, ii) = "" Then w(5, ii) = a(i, 5): Exit For
                        Next
                        .Item(a(i, 1)) = w
                    End If
                End If
            Next
            n = 1
            For Each e In .keys
                w = .Item(e)
                For i = 1 To UBound(w, 2)
                    n = n + 1
                    For ii = 1 To UBound(w, 1)
                        a(n, ii) = w(ii, i)
                    Next
                Next
            Next
        End With
        With .Offset(, .Columns.Count + 1).Resize(n)
            .Value = a
            .Offset(1).Sort .Cells(1), 1
        End With
    End With
End Sub

Display More

jindon · Oct 21st 2015

Re: consolidate rows into single row

Ahhh, sory. bugs..
It was left 5, but should be 6 since you have comments in col.C
Change

Code

ElseIf a(i, 5) <> "" Then 
                    If .exists(a(i, 1)) Then 
                        w = .Item(a(i, 1)) 
                        For ii = 1 To UBound(w, 2) 
                            If w(5, ii) = "" Then w(5, ii) = a(i, 5): Exit For 
                        Next 
                        .Item(a(i, 1)) = w 
                    End If 
                End If

to

Code

ElseIf a(i, 6) <> "" Then
                    If .exists(a(i, 1)) Then
                        w = .Item(a(i, 1))
                        For ii = 1 To UBound(w, 2)
                            If w(6, ii) = "" Then w(6, ii) = a(i, 6): Exit For
                        Next
                        .Item(a(i, 1)) = w
                    End If
                End If

jindon · Oct 21st 2015

Re: consolidate rows into single row

That's what I am saying, you have only one data in col.E that is E2.

jindon · Oct 20th 2015

Re: consolidate rows into single row

I don't understand what you mean.

You have no Time Out data to extract.

jindon · Oct 20th 2015

Re: consolidate rows into single row

What row in the result?

jindon · Oct 20th 2015

Re: VBA - first to match Name with data range and perform Hlookup

Quote from RP_1985;758618

Any help doing this on a VBA will be much appreciated. Spreadsheet attached for workings

Code

Sub test()
    Dim a, i As Long, ii As Long, w, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    a = [a11].CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        dic(a(i, 1)) = Empty: w = Empty
        For ii = 3 To UBound(a, 2)
            If a(i, ii) <> "" Then
                If IsEmpty(w) Then
                    ReDim w(0)
                Else
                    ReDim Preserve w(UBound(w) + 1)
                End If
                w(UBound(w)) = a(i, ii)
            End If
        Next
        If IsEmpty(w) Then
            dic.Remove a(i, 1)
        Else
            dic(a(i, 1)) = w
        End If
    Next
    With [a3].CurrentRegion
        a = .Value
        ReDim w(1 To UBound(a, 1), 1 To UBound(a, 2) - 3)
        w(2, 1) = "Reulst"
        For i = 3 To UBound(a, 1)
            If dic.exists(a(i, 1)) Then
                For ii = 4 To UBound(a, 2)
                    For Each e In dic(a(i, 1))
                        If CDate(e) = a(2, ii) Then
                            w(i, ii - 3) = e: Exit For
                        End If
                    Next
                Next
            End If
        Next
        With .Offset(, .Columns.Count + 1).Resize(, UBound(w, 2))
            .CurrentRegion.Clear
            .Value = w
            With .Rows(2)
                .HorizontalAlignment = 7
                .Font.FontStyle = "bold italic"
                .Font.Underline = True
                .BorderAround Weight:=2
            End With
            .NumberFormat = "d-mmm-yy"
            On Error Resume Next
            With .Offset(2).Resize(.Rows.Count - 2).SpecialCells(4)
                .NumberFormat = "0": .Value = 0
            End With
            On Error GoTo 0
            .Offset(2).Resize(.Rows.Count - 2).Borders.Weight = 2
            .Columns.AutoFit
        End With
    End With
End Sub

Display More

jindon · Oct 20th 2015

Re: Consolidating data from multiple client records

Try

Code

Sub test()
    Dim a, i As Long, ii As Long, ub As Long, w
    a = Sheets("What I have").Cells(1).CurrentRegion.Value
    ub = UBound(a, 2)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = VBA.Array(.Count + 1, ub)
                For ii = 1 To ub
                    a(.Count, ii) = a(i, ii)
                Next
            Else
                w = .Item(a(i, 1)): w(1) = w(1) + 1
                If UBound(a, 2) < w(1) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                End If
                a(w(0), w(1)) = a(i, ub): .Item(a(i, 1)) = w
            End If
        Next
        i = .Count
    End With
    With Sheets("What I want").Cells(1).Resize(i, UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a
        If .Columns.Count > ub Then
            With .Cells(1, ub)
                .Formula = "=""" & .Value & """&"" ""&char(column(a1)+64)"
                .AutoFill .Resize(, UBound(a, 2) - ub + 1)
            End With
        End If
        .CurrentRegion.Columns.AutoFit
        .Parent.Select
    End With
End Sub

Display More

jindon · Oct 20th 2015

Re: Application-defined or object-defined error

That code you are referring to in you first post is useless when you have many rows and the code I posted here is much faster.

jindon · Oct 20th 2015

Re: Create Summary and Report from text file

Changeg "myReport" to

Code

Sub myReport()
    Dim fn As String, txt, m, n As Long, temp, a(), x, w, myArea
    fn = Application.GetOpenFilename("TextFiles,*.txt")
    If fn = "False" Then Exit Sub
    n = 1: ReDim a(1 To 1): a(n) = Array("Area", "Records", "Amunt"):
    txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
    temp = txt
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True: .IgnoreCase = True
        .Pattern = "^\| *Location (Code|Total) *: *(?:[^:]+:)? *(\d+) *\|? *(\S.*\d+|[\d,\.]+) *.*$"
        For Each m In .Execute(txt)
            Set x = m.submatches
            If x(0) = "Code" Then
                n = n + 1
                ReDim Preserve a(1 To n)
                a(n) = VBA.Array(x(2), Empty, Empty)
            Else
                w = a(n): w(1) = x(1): w(2) = Replace(x(2), ",", "")
                a(n) = w
            End If
        Next
    End With
    With Sheets("summary").[a1].Resize(n, 3)
        .CurrentRegion.ClearContents
        .Value = Application.Index(a, 0, 0)
        .Rows(.Rows.Count + 1).Range("b1:c1").Formula = "=sum(r2c:r[-1]c)"
        .Columns(3).Resize(n + 1).NumberFormat = "#.00"
        .Columns.AutoFit
    End With
    myQuery temp
End Sub

Display More

jindon · Oct 20th 2015

Re: Create Summary and Report from text file

Run date issue.

Code

Private Sub myQuery(ByVal txt As String)
    Dim fn As String, a(), x, y, i As Long, ii As Long, maxCol As Long, myDate As String
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True: .IgnoreCase = True
        .Pattern = "RUN DATE.*"
        If .test(txt) Then myDate = .Execute(txt)(0)
        txt = Mid$(txt, InStr(txt, "|"))
        .Pattern = "^\|[=-]+\|[\r\n]+|^\| *(?=Location *)"
        txt = .Replace(txt, "")
        .Pattern = "Location"
        txt = Mid$(txt, .Execute(txt)(0).firstindex + 1)
    End With
    x = Split(txt, vbCrLf): ReDim a(1 To UBound(x) + 2, 1 To 100)
    For i = 0 To UBound(x)
        x(i) = LTrim$(RTrim$(x(i)))
        If x(i) <> "" Then
            y = Split(x(i), "|")
            maxCol = Application.Max(maxCol, UBound(y) + 1)
            If UBound(a, 2) < maxCol Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To maxCol)
            End If
            For ii = 0 To UBound(y)
                a(i + 1, ii + 1) = y(ii)
            Next
        End If
    Next
    With Sheets("sheet1").[a1].Resize(, maxCol)
        .Parent.Cells.ClearContents
        .Cells(1).Value = myDate
        .Offset(1).Resize(UBound(a, 1)).Value = a
    End With
End Sub

Display More

Upload a txt file, I only work with uploaded file.

jindon · Oct 20th 2015

Re: Conciliation by reference and Amount

VBA

Code

Sub test()
    Dim a, i As Long, ii As Long
    With Sheets("accounting").Cells(1).CurrentRegion.Resize(, 7)
        .Columns("g").Offset(2).Resize(.Rows.Count - 2, 1).Value = "Not conciliated"
        a = .Value
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 3 To UBound(a, 1)
            .Item(a(i, 2)) = VBA.Array(a(i, 4), a(i, 5), i)
        Next
        With Sheets("bank").Cells(1).CurrentRegion.Resize(, 7)
            .Columns("g").Offset(2).Resize(.Rows.Count - 2, 1).Value = "Not conciliated"
            a = .Value
        End With
        For i = 3 To UBound(a, 1)
            If .exists(a(i, 2)) Then
                For ii = 4 To 5
                    If a(i, ii) <> "" Then
                        If a(i, ii) = .Item(a(i, 2))(IIf(ii = 4, 1, 0)) Then
                            Sheets("bank").Cells(i, 7).Value = "Conciliated"
                            Sheets("accounting").Cells(.Item(a(i, 2))(2), 7).Value = "Conciliated"
                        End If
                    End If
                Next
            End If
        Next
    End With
End Sub

Display More

jindon · Oct 20th 2015

Re: Application-defined or object-defined error

Code

Sub test()
    Dim a, i As Long, ii As Long, n As Long
    With Cells(1).CurrentRegion.Resize(, 3)
        .Columns(3).ClearContents
        a = .Value
        For i = 1 To UBound(a, 1)
            For ii = 1 To UBound(a, 1)
                If a(i, 1) = a(ii, 2) Then
                    n = n + 1: a(n, 3) = a(i, 1): Exit For
                End If
            Next
        Next
        .Value = a
    End With
End Sub

Display More

jindon · Oct 17th 2015

Re: consolidate rows into single row

Try change to

Code

Sub MOformat()
    Dim a, i As Long, ii As Long, e, w, n As Long
    With Cells(1).CurrentRegion
        a = .Value: ReDim w(1 To UBound(a, 2))
        VSortM a, 2, UBound(a, 1), 4, 0
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 4) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        ReDim w(1 To UBound(a, 2), 1 To 1)
                    Else
                        w = .Item(a(i, 1))
                        ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
                    End If
                    For ii = 1 To UBound(a, 2)
                        w(ii, UBound(w, 2)) = a(i, ii)
                    Next
                    .Item(a(i, 1)) = w
                ElseIf a(i, 5) <> "" Then
                    If .exists(a(i, 1)) Then
                        w = .Item(a(i, 1))
                        For ii = 1 To UBound(w, 2)
                            If w(5, ii) = "" Then w(5, ii) = a(i, 5): Exit For
                        Next
                        .Item(a(i, 1)) = w
                    End If
                End If
            Next
            n = 1
            For Each e In .keys
                w = .Item(e)
                For i = 1 To UBound(w, 2)
                    n = n + 1
                    For ii = 1 To UBound(w, 1)
                        a(n, ii) = w(ii, i)
                    Next
                Next
            Next
        End With
        With .Offset(, .Columns.Count + 1).Resize(n)
            .Value = a
            .Offset(1).Sort .Cells(1), 1
        End With
    End With
End Sub


Sub VSortM(ary, LB, UB, ref, myOrd As Boolean)
    Dim i As Long, ii As Long, iii As Long, M, temp
    i = UB: ii = LB
    M = ary(Int((LB + UB) / 2), ref)
    Do While ii <= i
        If myOrd Then
            Do While ary(ii, ref) < M
                ii = ii + 1
            Loop
            Do While ary(i, ref) > M
                i = i - 1
            Loop
        Else
            Do While ary(ii, ref) > M
                ii = ii + 1
            Loop
            Do While ary(i, ref) < M
                i = i - 1
            Loop
        End If
        If ii <= i Then
            For iii = LBound(ary, 2) To UBound(ary, 2)
                temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
            Next
            i = i - 1: ii = ii + 1
        End If
    Loop
    If LB < i Then VSortM ary, LB, i, ref, myOrd
    If ii < UB Then VSortM ary, ii, UB, ref, myOrd
End Sub

Display More

jindon · Oct 16th 2015

Re: Filter, Sort, Macro... what to do?

Can you upload a sample workbook?

Posts by jindon

select row and chane fonts with VBA

How do I automate to select particular columns from the mastersheet to another sheet

How do I automate to select particular columns from the mastersheet to another sheet

consolidate rows into single row

VBA - first to match Name with data range and perform Hlookup

consolidate rows into single row

consolidate rows into single row

consolidate rows into single row

consolidate rows into single row

consolidate rows into single row

consolidate rows into single row

VBA - first to match Name with data range and perform Hlookup

Consolidating data from multiple client records

Application-defined or object-defined error

Create Summary and Report from text file

Create Summary and Report from text file

Conciliation by reference and Amount

Application-defined or object-defined error

consolidate rows into single row

Filter, Sort, Macro... what to do?