Date and Alpha Numeric Data Breaks into multiple rows in vba Code

awanak

New Member
Joined
Oct 6, 2018
Messages
36
Office Version
  1. 2019
Platform
  1. Windows
I have date at Dn.Offset(, "1") and long alphanumeric string at Dn.Offset(, 3) in the under mentioned code. But upon running the code date is broken into multiple rows and long alphanumeric string also breaks whenever there is / in the text.

Sub MG21Oct21()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, nn As Long, Sp As Variant, c As Long
Dim K As Variant, KK As Variant, Txt As String

Set Rng = Range("F2", Range("F" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

For Each Dn In Rng
If Not Dn.Value = vbNullString Then
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn.Offset(, "1") & "/" & Dn.Offset(, 3) & "/" & Dn.Offset(, -4) & ", " & Dn.Offset(, -3).Value & " (" & Dn.Offset(, -1).Value & ")"
Else
.Item(Dn.Value) = .Item(Dn.Value) & "/" & Dn.Offset(, -4) & ", " & Dn.Offset(, -3).Value & " (" & Dn.Offset(, -1).Value & ")" & ""
End If
End If
Next
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

ReDim Ray(1 To Rng.Count * 3, 1 To 2)
For Each K In .keys
Txt = Split(K, "-")(0)
Dic(Txt) = Dic(Txt) + 1
Next K
c = 1
Ray(c, 1) = "Center:=Name/Desg/Post"
For Each KK In Dic.keys
For n = 1 To Rng.Count * 3
If .Exists(KK & "-" & n) Then
c = c + IIf(c = 1, 1, 2)
Ray(c, 1) = KK & "-" & n
Sp = Split(.Item(Ray(c, 1)), "/")
For nn = 0 To UBound(Sp)
c = c + 1
Ray(c, 1) = Sp(nn)
Next nn
End If
Next n
Next KK
With Sheets("Sheet2").Range("B1").Resize(c)
.Value = Ray
.Borders.Weight = 2
.Columns.AutoFit
End With
End With
End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,599
Office Version
  1. 2013
Platform
  1. Windows
If you could provide an XL2BB minisheet of your worksheet with the data the code is working with that would help diagnose the cause of your issue.
 

awanak

New Member
Joined
Oct 6, 2018
Messages
36
Office Version
  1. 2019
Platform
  1. Windows
Book1
ABCDEFGHIJKL
1S.NoNameDesignationBSPlace of PostingPhase-III/21Previous Duty (Local)Previous Duty (Outstation)
2Hall No.FromToName of CentreNo. of Days
31Mr. AkramDG20C&RLahore-127-08-202121-09-2021FPSC, F-5/1, Aga Khan Road, Islamabad 2700
42Mr. AliceEDG20AdmnLahore-127-08-202121-09-2021FPSC, F-5/1, Aga Khan Road, Islamabad 2700
53Ms. ShizaAssistant Director 20SecrecyLahore-127-08-202121-09-2021FPSC, F-5-1, Aga Khan Road, Islamabad 2700
64Mr. Wiki Steno19T&SMultan-127-08-202121-09-2021Education University, Multan2700
75Mr. Sumroon EphrahimAssistant 19LegalMultan-127-08-202121-09-2021Education University, Multan2700
86Mr. David WilliamsUDC19HRMultan-127-08-202121-09-2021Education University, Multan2700
Sheet1
Cell Formulas
RangeFormula
G3:G8G3=IFNA(INDEX('[Statement of Staff Phase-III-2021 2.xlsm]Sheet3'!$B$2:$B$500,MATCH(F3,'[Statement of Staff Phase-III-2021 2.xlsm]Sheet3'!$A$2:$A$500,0)), "---")
H3:H8H3=IFNA(INDEX('[Statement of Staff Phase-III-2021 2.xlsm]Sheet3'!$C$2:$C$500,MATCH(F3,'[Statement of Staff Phase-III-2021 2.xlsm]Sheet3'!$A$2:$A$500,0)), "---")
J3:J8J3=IFERROR(DAYS(H3, G3)+2, "0")
K3:K8K3=SUMIF(M3,"Secrecy*",P3)+SUMIF(M3,"R&I*",P3)+SUMIF(M3,"T&S*",P3)
L3:L8L3=SUMIFS(P3,M3,"<>Islamabad*", M3,"<>Secrecy*", M3,"<>R&I*", M3,"<>T&S*",$M$2:$M$2,"Phase*")
A4:A8A4=+A3+1
Cells with Conditional Formatting
CellConditionCell FormatStop If True
K3:L8,F1,K1:L1,G2:J2,F3:I8Cell Value="No Duty"textNO
 
Last edited:

awanak

New Member
Joined
Oct 6, 2018
Messages
36
Office Version
  1. 2019
Platform
  1. Windows
Here is the output i get after i run the code

Book2
A
1Center:=Name/Desg/Post
2Lahore-1
321
49
52021
6FPSC, F-5
71, Aga Khan Road, Islamabad
8Mr. Akram, DG (C&R)
9Mr. Alice, EDG (Admn)
10Ms. Shiza, Assistant Director (Secrecy)
11
12Multan-1
1321
149
152021
16Education University, Multan
17Mr. Wiki , Steno (T&S)
18Mr. Sumroon Ephrahim, Assistant (Legal)
19Mr. David Williams, UDC (HR)
Sheet1
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,599
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

The solution could be to NOT use the slash character / as a delimiter since in VBA dates in are handled in US-style. Would suggest to use a unique, multi-character delimiter instead.

Rich (BB code):
Sub MG21Oct21()

    Const DELIM As String = "$@#@$"
    
    Dim Rng As Range, Dn As Range, n As Long, Dic As Object, nn As Long, Sp As Variant, c As Long
    Dim K As Variant, KK As Variant, Txt As String

    Set Rng = Range("F3", Range("F" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare

        For Each Dn In Rng
            If Not Dn.Value = vbNullString Then
                If Not .Exists(Dn.Value) Then
                    .Add Dn.Value, Dn.Offset(, "1") & DELIM & Dn.Offset(, 3) & DELIM & Dn.Offset(, -4) & ", " & Dn.Offset(, -3).Value & " (" & Dn.Offset(, -1).Value & ")"
                Else
                    .Item(Dn.Value) = .Item(Dn.Value) & DELIM & Dn.Offset(, -4) & ", " & Dn.Offset(, -3).Value & " (" & Dn.Offset(, -1).Value & ")" & ""
                End If
            End If
        Next
        Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare

        ReDim Ray(1 To Rng.Count * 3, 1 To 2)
        For Each K In .keys
            Txt = Split(K, "-")(0)
            Dic(Txt) = Dic(Txt) + 1
        Next K
        c = 1
        Ray(c, 1) = "Center:=Name/Desg/Post"
        For Each KK In Dic.keys
            For n = 1 To Rng.Count * 3
                If .Exists(KK & "-" & n) Then
                    c = c + IIf(c = 1, 1, 2)
                    Ray(c, 1) = KK & "-" & n
                    Sp = Split(.Item(Ray(c, 1)), DELIM)
                    For nn = 0 To UBound(Sp)
                        c = c + 1
                        Ray(c, 1) = Sp(nn)
                    Next nn
                End If
            Next n
        Next KK
        With Sheets("Sheet2").Range("B1").Resize(c)
            .Value = Ray
            .Borders.Weight = 2
            .Columns.AutoFit
        End With
    End With
End Sub
 
Solution

awanak

New Member
Joined
Oct 6, 2018
Messages
36
Office Version
  1. 2019
Platform
  1. Windows
Thanks a million. worked fine
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
2,599
Office Version
  1. 2013
Platform
  1. Windows
You are welcome and thanks for the feedback.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,566
Messages
5,770,893
Members
425,651
Latest member
Mark Cashin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top