Posts by jindon

jindon · Oct 13th 2015

Re: consolidate rows into single row

What is the reason to place blank row in row 1?
It's not a good practice and also a bad procedure name "sort"....

Code

Sub MOformat()
'combines in and out times onto single row for format and reporting
    
    Dim a, i As Long, ii As Long, w, n As Long
    With Cells(1).CurrentRegion
        a = .Value: ReDim w(1 To UBound(a, 2))
        mySort a, 3, UBound(a, 1), 4, 0
        With CreateObject("Scripting.Dictionary")
            For i = 3 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
            w = .items
        End With
        With .Offset(, .Columns.Count + 1)
            .Rows(1).Value = a: n = 3
            For i = 0 To UBound(w)
                .Rows(n).Resize(UBound(w(i), 2)).Value = Application.Transpose(w(i))
                n = n + UBound(w(i), 2)
            Next
            With .Offset(2).Resize(n)
                .sort .Cells(1), 1, , , , , , 1
            End With
        End With
    End With
End Sub

Display More

jindon · Oct 13th 2015

Re: auto generate table based on selection w/ variables

Assuming:
1) Data in Sheet1, header starting from A1
2) Output to Sheet2

Code

Sub test()
    Dim a(), i As Long, x, n As Long, maxRow As Long
    With Sheets("sheet1").Cells(1).CurrentRegion
        ReDim a(1 To .Rows.Count)
        For i = 2 To .Rows.Count
            x = Filter(.Parent.Evaluate("if(" & .Rows(i).Address & "<>""""," & _
            .Rows(1).Address & ",char(2))"), Chr(2), 0)
            If UBound(x) > -1 Then
                x(0) = .Cells(i, 1).Value
                maxRow = Application.Max(maxRow, UBound(x) + 1)
                ReDim Preserve x(.Columns.Count - 1)
                n = n + 1: a(n) = x
            End If
        Next
        ReDim Preserve a(1 To n)
        Sheets("sheet2").Cells(1).Resize(maxRow, n).Value = _
        Application.Transpose(Application.Index(a, 0, 0))
    End With
End Sub

Display More

jindon · Oct 12th 2015

Re: Populate Dates in different cells between date range - VBA

I'm not following you, Good luck.

jindon · Oct 12th 2015

Re: Randomized Task Rota

See if this is how you wanted

Code

Option Explicit
Option Compare Text
Sub test()
    Dim a, i As Long, temp As String, e, s, flg As Boolean, dic As Object
    Const txt As String = "Others"
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Cells(1).CurrentRegion.Resize(, 6)
        a = .Value
        For i = 2 To UBound(a, 1)
            If a(i, 4) = "" Then
                temp = a(i, 5)
                Select Case temp
                    Case "Seniors"
                        If Trim$(Split(a(i, 6))(1)) Like "[1-4]" Then flg = True
                    Case "ESI"
                        If Trim$(Split(a(i, 6))(1)) Like "[56]" Then flg = True
                    Case Else: temp = txt: flg = True
                End Select
                If flg Then
                    If Not dic.exists(temp) Then
                        ReDim w(1 To 2)
                    Else
                        w = dic(temp)
                    End If
                    w(1) = w(1) & IIf(w(1) <> "", Chr(2), "") & i
                    w(2) = w(2) & IIf(w(2) <> "", Chr(2), "") & a(i, 6)
                    dic(temp) = w
                End If
            End If
            flg = False
        Next
        Randomize
        With CreateObject("System.Collections.SortedList")
            For Each e In dic
                For Each s In Split(dic(e)(1), Chr(2))
                    .Item(Rnd) = s
                Next
                For i = 0 To .Count - 1
                    a(.GetByIndex(i), 6) = Split(dic(e)(2), Chr(2))(i)
                Next
                .Clear
            Next
        End With
        .Value = a
    End With
End Sub

Display More

jindon · Oct 12th 2015

Re: Randomized Task Rota

Having read your instructions, hard to understand how you want it.
Do you want

1) Randomize col.F within Name 1- 4 where col.E has Senior
2) Randomize col.F within Name 8 - 9 where col.E has ESI
?
Third criteria is not clear to me.

jindon · Oct 12th 2015

Re: Repeat Transpose - Repeat amount of Rows.

See if this is how you wanted

Code

Sub test()
    Dim i As Long, n As Long
    With Sheets("sheet1")
        For i = 1 To .Range("a" & Rows.Count).End(xlUp).Row Step 32
            n = n + 2
            .Cells(i, 1).Resize(32).Copy
            Sheets("sheet2").Cells(n, 1).Resize(2).PasteSpecial Transpose:=True
        Next
    End With
End Sub

jindon · Oct 12th 2015

Re: Distribute several unique data from one cell to multiple cells

For the data provided in the link.

Code

Sub test()
    Dim r As Range
    With Range("a3", Range("a" & Rows.Count).End(xlUp))
        For Each r In .SpecialCells(2).Areas
            r(0, 3).Copy r.Offset(, 3)
        Next
        .SpecialCells(4).EntireRow.Delete
    End With
End Sub

jindon · Oct 11th 2015

Re: Help in Array

1) You are still missing link(s). This is required.

2) Post a workbook with before/after.

jindon · Oct 11th 2015

Re: Help in Array

1) You must give us all the link(s) that you posted same question in other forum(s).

2) You must use code tag when you post vba code.

That's all in forum rule.

jindon · Oct 11th 2015

Re: Help in Array

You must follow the forum rule before ask anything.

jindon · Oct 11th 2015

Re: Retrieve Most Recent Data In Column

The attached always updates automatically whenever you select "Latest Ratings" sheet.
In ThisWorkbook module

Code

Private Sub Workbook_Open()
    Run Sheets("latest ratings").CodeName & ".worksheet_activate"
End Sub

In "Latest Ratings" sheet module

Code

Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False
    Me.[b6].CurrentRegion.Clear
    Sheets("rating history").[b4].CurrentRegion.Copy Me.[b6]
    With Me.[b6].CurrentRegion
        .Sort .Cells(1, 3), 2, , , , , , 1
        .RemoveDuplicates 1, 1
        .Sort .Cells(1, 1), 1, , , , , , 1
    End With
    Application.ScreenUpdating = True
End Sub

Display More

jindon · Oct 11th 2015

Re: Retrieve Most Recent Data In Column

I would not use formula....

You can either use vba or do it manually...
1) select data range and copy including header.
2) paste to the other sheet and sort descending by date.
3) go to [RemoveDuplicates] by first column.
4) sort ascending by first column.

That's what the code does.

jindon · Oct 11th 2015

Re: Retrieve Most Recent Data In Column

Try

Code

Sub test()
    With Sheets("latest ratings")
        .[b6].CurrentRegion.Clear
        Sheets("rating history").[b4].CurrentRegion.Copy .[b6]
        With .[b6].CurrentRegion
            .Sort .Cells(1, 3), 2, , , , , , 1
            .RemoveDuplicates 1, 1
            .Sort .Cells(1, 1), 1, , , , , , 1
        End With
    End With
End Sub

Display More

Hummm Formula...
C7
=INDEX('Rating History'!$B$5:$D$8,MAX(IF('Rating History'!$B$5:$B$8=$B7,ROW('Rating History'!$B$5:$B$8)-4)),COLUMN(B1))
confirm with Ctrl + Shift + Enter (Array forumla entry)
then copy right + down.

jindon · Oct 9th 2015

Re: Macro to combine rows with common data and delete duplicates

Try change to

Code

Sub test()
    Dim a, i As Long, ii As Long, w
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = .Count + 2
                For ii = 1 To UBound(a, 2)
                    a(.Count + 1, ii) = a(i, ii)
                Next
            Else
                For ii = 1 To UBound(a, 2)
                    If a(i, ii) <> "" Then a(.Item(a(i, 1)), ii) = a(i, ii)
                Next
            End If
        Next
        i = .Count + 1
    End With
    With Sheets("sheet2").Cells(1).Resize(i, UBound(a, 2))
        .CurrentRegion.ClearContents
        .Columns(1).NumberFormat = "@"
        .Value = a
    End With
End Sub

Display More

jindon · Oct 9th 2015

Re: Add a column with file name while importing .csv file in vba

See if this is how you wanted (not tested)

Code

Sub Button3_Click()
    Sheet1.Cells.ClearContents
     
    Dim myDir As String, fn As String, ff As Integer, txt As String, flg As Boolean
    Dim delim As String, n As Long, b() As Variant, x As Variant, t As Integer, i As Long
     
    myDir = "C:\Users\ASUS\Documents\Basket Stocks"
    delim = vbTab
    
    i = 1
    
    fn = Dir(myDir & "\*.csv")
    Do While fn <> ""
         
        ReDim b(1 To Rows.Count, 1 To 2)
        ff = FreeFile
        Open myDir & "\" & fn For Input As #ff
         
         '   Line Input #ff, txt  'Ignore header line
         
        Do While Not EOF(ff)
            Line Input #ff, txt
            x = Split(txt, delim)
            If Not flg Then
                n = n + 1: b(n, 1) = fn
                flg = True
            End If
            If UBound(x) > 0 Then
                n = n + 1
                b(n, 1) = x(2)
                b(n, 2) = x(1)
            End If
        Loop
         
         
         '  Columns(1).NumberFormat = "@"   'text
         '  Columns(2).NumberFormat = "General"  'general
         '  Columns(3).NumberFormat = "0"      'number
         
         '  Columns(1).NumberFormat = "0.00"
         ' Columns(3).NumberFormat = "0.00"
         
         
         
         
        Close #ff
        ThisWorkbook.Sheets(1).Cells(i, 1).Resize(n, 2).Value = b
        i = i + n + 2
        n = 0
        fn = Dir()
        flg = False
         
    Loop
     
     
End Sub

Display More

Originally
http://www.ozgrid.com/forum/showthread.php?t=80643

jindon · Oct 9th 2015

Re: Array of Booleans from Excel to VBA

When you read the data from the range to the array variable, it must be a VARIANT type.

jindon · Oct 8th 2015

Re: Populate Dates in different cells between date range - VBA

See................

jindon · Oct 8th 2015

Re: Highlights Cells Begins with Multiple Criteria

That is equivalent to

Code

Set Lookin = Columns(1).Find(What:= xItem & "*", LookAt:= xlWhole, MatchCase:= False)

xItem & "*" means cell begin with xItem.

Code

Sub HighlightCells()
    Dim Lookin As Range, ff As String
    Dim xItem As Variant, FND
     
    FND = Range("b2", Range("b" & Rows.Count).End(xlUp)).Value




    For Each xItem In FND
        Set Lookin = Columns(1).Find(xItem & "*", , , 1, , , 0)
        If Not Lookin Is Nothing Then
            ff = Lookin.Address
            Do
                Lookin.Characters(1, Len(xItem)).Font.ColorIndex = 3
                Set Lookin = Columns(1).FindNext(Lookin)
            Loop Until ff = Lookin.Address
        End If
        Set Lookin = Nothing
    Next
End Sub

Display More

jindon · Oct 8th 2015

Re: Highlights Cells Begins with Multiple Criteria

Just a little alteration of pike's

Code

Sub HighlightCells()
    Dim Lookin As Range, ff As String
    Dim i As Long
    Dim Fnd As Variant
    Dim fCell As Range
    Dim ws As Worksheet
    Dim xItem As Variant
     
    Fnd = Range("b2", Range("b" & Rows.Count).End(xlUp)).Value




    For Each ws In Worksheets
        With Sheets(ws.Name)
            For Each xItem In Fnd
                Set Lookin = Columns(1).Find(xItem & "*", , , 1, , , 0)
                If Not Lookin Is Nothing Then
                    ff = Lookin.Address
                    Do
                        Lookin.Characters(1, Len(xItem)).Font.ColorIndex = 3
                        Set Lookin = Columns(1).FindNext(Lookin)
                    Loop Until ff = Lookin.Address
                End If
                Set Lookin = Nothing
            Next
        End With
    Next
     
End Sub

Display More

jindon · Oct 7th 2015

Re: Populate Dates in different cells between date range - VBA

Try

Code

Sub test()
    Dim a, i As Long, ii As Long, w, x, ub As Long
    a = Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To 2)
                For ii = 1 To 2
                    w(ii) = a(i, ii)
                Next
                .Item(a(i, 1)) = w
            Else
                w = .Item(a(i, 1))
            End If
            ub = UBound(w)
            x = DateDiff("d", a(i, 3), a(i, 4)) + 1
            ReDim Preserve w(1 To UBound(w) + x)
            For ii = ub + 1 To UBound(w)
                w(ii) = a(i, 3) + ii - ub - 1
            Next
            .Item(a(i, 1)) = w
        Next
        For i = 0 To .Count - 1
            Cells(i + 2, "g").Resize(, UBound(.items()(i))) = .items()(i)
        Next
    End With
    With [g2].CurrentRegion
        .Offset(, 2).NumberFormat = "d-mmm"
        .Columns.AutoFit
    End With
End Sub

Display More