Posts by MickG

MickG · May 10th 2014

Re: Duplication Help!!

Try this:-

Code

Sub oColor()
Dim Rng         As Range
Dim Dn          As Range
Dim n           As Long
Dim oWd         As Variant
Dim Ac          As Long
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
For Each Dn In Rng
oWd = Split(Dn, ",")
    For n = 0 To UBound(oWd)
    If Not .Exists(oWd(n)) Then
        .Add oWd(n), Nothing
    Else
        For Ac = 1 To Len(Dn)
            If Dn.Characters(Ac, Len(oWd(n))).Text = oWd(n) Then
                With Dn.Characters(Ac, Len(oWd(n))).Font
                    .ColorIndex = 3
                    .Bold = True
                End With
            End If
        Next Ac
    End If
Next n
Next Dn
End With
            End Sub

Display More

Regards Mick

MickG · May 10th 2014

Re: Aligning 5 rows in Column B with 24 rows in Column A

To run code try this:-
To Save and Run Code:-
Copy code from Thread
In Your Data sheet , Click "Alt+F11",:- Vb Window appears.
From the VBWindow Toolbar, Click "Insert" ,"Module":- New VBwindow appears .
Paste Code into this window.
Close Vbwindow.

On sheet Click "Developer tab", Click "Macro". Macro dialog box appears.
Select Macro (with same name) from List.
On the right of Dialog box Click "Run"
The Sheet should now be updated.
Regrds Mick

MickG · May 9th 2014

Re: Aligning 5 rows in Column B with 24 rows in Column A

Try this:-

Code

Sub Align()
Dim Rng         As Range
Dim Dn          As Range
Dim Dic         As Object
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Set Dic = CreateObject("scripting.dictionary")
  Dic.CompareMode = vbTextCompare
    For Each Dn In Rng: Set Dic.Item(Dn.Value) = Dn: Next
        Set Rng = Range(Range("B2"), Range("b" & Rows.Count).End(xlUp))
For Each Dn In Rng
    If Dic.exists(Dn.Value) Then Dn.Resize(, 3).Cut Dic.Item(Dn.Value).Offset(, 1)
Next Dn
End Sub

Display More

MickG · May 8th 2014

Re: Area_Rectange

This looks a bit like Homework, if so what have you got so far ?????

MickG · May 7th 2014

Re: Area_Rectange

Try:-

Code

Public Function Area_rectangle(length As Double, breadth As Double) As Double
    Area_rectangle = length * breadth
End Function

MickG · Apr 24th 2014

Re: Get column name of a cell

Perhaps this:-
Data sheet1, Results sheet2

Code

Sub Trans()
Dim a As Range, x, c As Long, r As Long




Set a = Sheets("sheet1").Cells(1).CurrentRegion
c = a.Columns.Count - 1
r = 2
With Sheets("sheet2")
    .Range("A1").Resize(, 3) = Array("Date", "Country", "Share of Exports")
    For Each x In a.Resize(, 1)
        If Len(x) > 0 And IsNumeric(x) Then
            .Cells(r, 1).Resize(c) = x
            .Cells(r, 2).Resize(c) = Application.Transpose(a(1, 2).Resize(, c))
            .Cells(r, 3).Resize(c) = Application.Transpose(x.Offset(, 1).Resize(, c))
            r = r + c
        End If
    Next x
End With
End Sub

Display More

MickG · Apr 6th 2014

Re: Colour only alphabets if a cell contains alphanumeric values.

Try this for single cell selection.

Code

Dim n As Integer
Dim Num As Integer
If selection.Count = 1 Then
For n = 1 To Len(selection)
    Num = Asc(selection.Characters(n, 1).Text)
    If Num >= 65 And Num <= 92 Or Num >= 97 And Num <= 122 Then
        selection.Characters(n, 1).Font.ColorIndex = 3
    End If
Next n
End If

MickG · Apr 6th 2014

Re: Adding Numbered Patterns vertically

When I run the code on your most recent file those Rows that you refere to (9,13,15,17,19,20,23,27,28,30, ) are returned Blank !!!!
Does your most recent file, show in column "H", the answer that you want, or that you don't want.
If the Latter please show your Expected correct result.

MickG · Apr 5th 2014

Re: Adding Numbered Patterns vertically

Try this, results in column "H" of "Count vertical.xlsx"

Code

Sub oCount()
Dim Rng As Range
Dim Dn As Range
Dim Ac As Integer
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Ac = 3 To 6
Set Rng = Range(Cells(4, Ac), Cells(Rows.Count, Ac).End(xlUp))
For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
         .Add Dn.Value, Dn
    Else
        Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    End If
Next
Next Ac
Dim k As Variant
Dim A As Range
 For Each k In .keys
    For Each A In .Item(k).Areas
        If A.Count > 1 Then
            Range("H" & A(1).Row) = A.Count
        End If
    Next A
Next k
End With
End Sub

Display More

Regards Mick

MickG · Mar 9th 2014

Re: compare sheets b/w 1 & 2 & Move (matching) original & duplicate entire rows to sh

You're welcome
Regrds Mick

MickG · Mar 8th 2014

Re: compare sheets b/w 1 & 2 & Move (matching) original & duplicate entire rows to sh

Try this:-

Code

Sub Trans()
Dim Rng As Range
Dim Dn As Range
Dim Dic As Object
Dim Rng1 As Range
Dim Rng2 As Range
Dim c As Long
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
    Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
For Each Dn In Rng: Set Dic(Dn.Value) = Dn: Next




With Sheets("Sheet2")
Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With




For Each Dn In Rng
    If Dic.exists(Dn.Value) Then
        If Rng1 Is Nothing Then
            Set Rng1 = Dic.Item(Dn.Value)
        Else
            Set Rng1 = Union(Rng1, Dic.Item(Dn.Value))
        End If
            If Rng2 Is Nothing Then
                Set Rng2 = Dn
            Else
                Set Rng2 = Union(Rng2, Dn)
            End If
          With Sheets("Sheet3")
            c = c + 2
            .Cells(c, 1).EntireRow.Value = Dn.EntireRow.Value
            .Cells(c + 1, 1).EntireRow.Value = Dic.Item(Dn.Value).EntireRow.Value
         End With
    End If
Next Dn
If Not Rng1 Is Nothing Then Rng1.EntireRow.Delete
If Not Rng2 Is Nothing Then Rng2.EntireRow.Delete
End sub

Display More

MickG · Mar 7th 2014

Re: Lookups for Nth Occurrence are Looping

This is an alternative Solution on sheet2.

MickG · Mar 7th 2014

Re: Pick Random number from a list, based on the value of another Random number

Perhaps this Game I wrote some time ago might help.

MickG · Mar 6th 2014

Re: Pick Random number from a list, based on the value of another Random number

This may or may not Help !!!!!

MickG · Mar 6th 2014

Re: Finding the difference in different versions of a timetable

Thank you "apo" nice to try somewhere new.
Regrds Mick

MickG · Mar 5th 2014

Re: Finding the difference in different versions of a timetable

Thank you for the feed back.
NB:- Jindon's code is well worth a second look.

Jindon, very nice code !!!

Regrds Mick

MickG · Mar 4th 2014

Re: Finding the difference in different versions of a timetable

Try this:-
Data Sheet 1, Results sheet 2.

Code

Sub Cal()
Dim Rng             As Range
Dim Dn              As Range
Dim n               As Long
Dim Ac              As Long
Dim c               As Integer
Dim Q               As Variant
Dim Dic             As Object
Dim K               As Variant
Dim Rw              As Long
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    ReDim Ray(1 To Rng.Count, 1 To 40)
    c = 0
    If Not UCase(Left(Dn, 4)) = "VERS" And Not UCase(Left(Dn, 4)) = "WEEK" And Not Dn = vbNullString Then
        If Not Dic.Exists(Dn.Value) Then
            n = n + 1
            For Ac = 1 To 40
                If Dn.Offset(, Ac).Interior.ColorIndex = 6 Then
                    c = c + 1
                    Ray(1, c) = Rng(3).Offset(, Ac)
                End If
            Next Ac
                Dic.Add Dn.Value, Array(Ray, 1, n)
        Else
            Q = Dic.Item(Dn.Value)
                Q(1) = Q(1) + 1
                For Ac = 1 To 40
                    If Dn.Offset(, Ac).Interior.ColorIndex = 6 Then
                        c = c + 1
                        Q(0)(Q(1), c) = Rng(3).Offset(, Ac)
                    End If
                Next Ac
            Dic.Item(Dn.Value) = Q
    End If
End If
Next








For Each K In Dic.keys
    With Sheets("Sheet2")
        Rw = Rw + 1
        .Cells(Rw, 1) = K
        .Cells(Rw, 1).Resize(, 40).Interior.ColorIndex = 6
        Rw = Rw + 1
        With .Cells(Rw, 1)
            .Value = "Version 1"
            .AutoFill Destination:=.Resize(Dic.Item(K)(1)), Type:=xlFillSeries
        End With
        .Cells(Rw, 2).Resize(Dic.Item(K)(1), 40) = Dic.Item(K)(0)
            Rw = Rw + Dic.Item(K)(1) + 1
    End With
Next K




MsgBox "run"
End Sub

Display More

MickG · Feb 25th 2014

Re: unique value 3 columns combined & sum

Try this:-
NB:- As there are no Serial Numbers , I've added them after the Sort.

Code

Sub Bill_1()
Dim Rng         As Range
Dim Dn          As Range
Dim oTxt        As String
Dim Q           As Variant
Dim Dic         As Object
Dim k           As Variant
Dim c           As Long
Dim oSum        As Double
With Sheets("bill1")
    Set Rng = .Range(.Range("M16"), .Range("M" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare




For Each Dn In Rng
    If Dn.Offset(, -4) = "Cheque" Then
        oTxt = Dn & Dn.Offset(, -2) & Dn.Offset(, -1)
        If Not Dic.Exists(oTxt) Then
            Dic.Add oTxt, Array(Dn, Val(Dn.Offset(, -6)))
        Else
            Q = Dic.Item(oTxt)
                Q(1) = Q(1) + Val(Dn.Offset(, -6))
            Dic.Item(oTxt) = Q
        End If
    End If
Next




ReDim Ray(1 To Dic.Count, 1 To 5)
  
For Each k In Dic.keys
    c = c + 1
    
    Ray(c, 1) = Dic.Item(k)(0)
    Ray(c, 2) = Dic.Item(k)(0).Offset(, -2)
    Ray(c, 3) = Dic.Item(k)(0).Offset(, -1)
    Ray(c, 4) = Dic.Item(k)(1)
    oSum = oSum + Dic.Item(k)(1)
Next k




With Sheets("Sheet1")
    .Range("A1:E1").Value = Array("Serial No", "Bank Name", "Cheq/DD No.", "Cheq/DD Date", "Amount")
    .Range("B2").Resize(c, 5) = Ray
    .Range("B2").Resize(c, 5).Sort .Range("B2"), xlAscending
    .Range("A2").Value = "001"
    .Range("A2").AutoFill Destination:=.Range("A2:A" & c + 1), Type:=xlFillSeries
    .Range("E" & c + 2) = oSum
    .Range("A2:A" & c + 1).NumberFormat = "000"
    .Range("A" & c + 2).Value = "Total :-"
    .Range("D" & c + 2).Value = "Sum ""Amount"" :-"
    .Range("B" & c + 2).Value = c
End With
End Sub

Display More

MickG · Feb 24th 2014

Re: unique value 3 columns combined & sum

Try this:-
Results "Sheet1"
Unless I've got it wrong, (Quite possible)your Data does not match your Results

Code

Sub Bill()
Dim Rng         As Range
Dim Dn          As Range
Dim oTxt        As String
Dim Q           As Variant
Dim Dic         As Object
Dim k           As Variant
Dim c           As Long
With Sheets("bill1")
    Set Rng = .Range(.Range("M16"), .Range("M" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare




For Each Dn In Rng
    If Dn.Offset(, -4) = "Cheque" Then
        oTxt = Dn & Dn.Offset(, -2) & Dn.Offset(, -1)
        If Not Dic.Exists(oTxt) Then
            Dic.Add oTxt, Array(Dn, Val(Dn.Offset(, -6)))
        Else
            Q = Dic.Item(oTxt)
                Q(1) = Q(1) + Val(Dn.Offset(, -6))
            Dic.Item(oTxt) = Q
        End If
    End If
Next




ReDim ray(1 To Dic.Count, 1 To 5)
  
For Each k In Dic.keys
    c = c + 1
    ray(c, 1) = Dic.Item(k)(0)
    ray(c, 2) = Dic.Item(k)(0).Offset(, -2)
    ray(c, 3) = Dic.Item(k)(0).Offset(, -1)
    ray(c, 4) = Dic.Item(k)(1)
    ray(c, 5) = k
Next k




With Sheets("Sheet1")
    .Range("A1:F1").Value = Array("Bank Name", "Cheq/DD No.", "Cheq/DD Date", "Amount", "to check unique value    :-)")
    .Range("A2").Resize(c, 5) = ray
    .Range("A2").Resize(c, 5).Sort .Range("A2"), xlAscending
End With
End Sub

Display More

Regards Mick

MickG · Feb 9th 2014

Re: Redim Array size

You need to change the Column index to row index and then Transpose the Final Array, as below:-
NB:- You can only increase the Column value in the "Redim Preserve" Statement.

Code

Sub Test()
Dim X As Variant
  Dim i As Long
  Dim n As Long
  Dim arr()
  X = Sheets("Merit").Range("A1").CurrentRegion.Value
  For i = UBound(X, 1) To 2 Step -1
        If Val(X(i, 1)) = Me.txtTMID.Value Then
            n = n + 1
        ReDim Preserve arr(1 To UBound(X, 2), 1 To n) '***I tried adding this line but to no avail
            arr(1, n) = X(i, 5)
            arr(2, n) = X(i, 4)
            arr(3, n) = X(i, 12)
            arr(4, n) = X(i, 6)
            arr(5, n) = X(i, 7)
            arr(6, n) = X(i, 8)
            arr(7, n) = X(i, 9)
            arr(8, n) = X(i, 10)
            arr(9, n) = X(i, 11)
        End If
    Next
    With Me.LstMerit
     .Clear
     .ColumnCount = 9
     .List = Application.Transpose(arr)
    End With
End Sub

Display More

Regards Mick

Posts by MickG

Highlight all duplicates after first occurence

Aligning 5 rows in Column B with 24 rows in Column A

Aligning 5 rows in Column B with 24 rows in Column A

Area_Rectange

Area_Rectange

Get column name of a cell

Colour only alphabets if a cell contains alphanumeric values.

Adding Numbered Patterns vertically

Adding Numbered Patterns vertically

compare sheets b/w 1 & 2 & Move (matching) original & duplicate entire rows to sheet3

compare sheets b/w 1 & 2 & Move (matching) original & duplicate entire rows to sheet3

Lookups for Nth Occurrence are Looping

Pick Random number from a list, based on the value of another Random number

Pick Random number from a list, based on the value of another Random number

Finding the difference in different versions of a timetable

Finding the difference in different versions of a timetable

Finding the difference in different versions of a timetable

unique value 3 columns combined & sum

unique value 3 columns combined & sum

Redim Array size