awanak
New Member
- Joined
- Oct 6, 2018
- Messages
- 37
- Office Version
- 2019
- Platform
- 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
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