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

[awanak]

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

 

[GWteB]

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]

Book1
	A	B	C	D	E	F	G	H	I	J	K	L
1	S.No	Name	Designation	BS	Place of Posting	Phase-III/21					Previous Duty (Local)	Previous Duty (Outstation)
2						Hall No.	From	To	Name of Centre	No. of Days
3	1	Mr. Akram	DG	20	C&R	Lahore-1	27-08-2021	21-09-2021	FPSC, F-5/1, Aga Khan Road, Islamabad	27	0	0
4	2	Mr. Alice	EDG	20	Admn	Lahore-1	27-08-2021	21-09-2021	FPSC, F-5/1, Aga Khan Road, Islamabad	27	0	0
5	3	Ms. Shiza	Assistant Director	20	Secrecy	Lahore-1	27-08-2021	21-09-2021	FPSC, F-5-1, Aga Khan Road, Islamabad	27	0	0
6	4	Mr. Wiki	Steno	19	T&S	Multan-1	27-08-2021	21-09-2021	Education University, Multan	27	0	0
7	5	Mr. Sumroon Ephrahim	Assistant	19	Legal	Multan-1	27-08-2021	21-09-2021	Education University, Multan	27	0	0
8	6	Mr. David Williams	UDC	19	HR	Multan-1	27-08-2021	21-09-2021	Education University, Multan	27	0	0
Sheet1

Cell Formulas
Range	Formula
G3:G8	G3	=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:H8	H3	=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:J8	J3	=IFERROR(DAYS(H3, G3)+2, "0")
K3:K8	K3	=SUMIF(M3,"Secrecy*",P3)+SUMIF(M3,"R&I*",P3)+SUMIF(M3,"T&S*",P3)
L3:L8	L3	=SUMIFS(P3,M3,"<>Islamabad*", M3,"<>Secrecy*", M3,"<>R&I*", M3,"<>T&S*",$M$2:$M$2,"Phase*")
A4:A8	A4	=+A3+1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
K3:L8,F1,K1:L1,G2:J2,F3:I8	Cell Value	="No Duty"	text	NO

 

[awanak]

Here is the output i get after i run the code

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

 

[GWteB]

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.

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

 

[awanak]

Thanks a million. worked fine

 

[GWteB]

You are welcome and thanks for the feedback.