ItalianPlatinum
Well-known Member
- Joined
- Mar 23, 2017
- Messages
- 793
- Office Version
- 365
- 2019
- Platform
- Windows
Hello,
I have a VBA code that works absolutely fabulously. It was provided to me on a very older thread here. And in simple terms it is little complex for me to dissect. All I am looking to do is add a new column in the file and I am fearful of it breaking the existing VBA. Is there someone that could help? So sheet Comp is getting a new column inserted at G
I have a VBA code that works absolutely fabulously. It was provided to me on a very older thread here. And in simple terms it is little complex for me to dissect. All I am looking to do is add a new column in the file and I am fearful of it breaking the existing VBA. Is there someone that could help? So sheet Comp is getting a new column inserted at G
VBA Code:
Sub List()
Const DataCell = "O7", FreezeCellRow = 7
Dim ShGrid As Worksheet, ShImpExp As Worksheet
Dim Rng As Range
Dim DicAcc As Object, DicGrp As Object
Dim Acc As String, Grp As String
Dim a() As Variant, Data() As Variant
Dim i As Long
Dim s As String, s1 As String
Dim IsHidden As Boolean
Set ShGrid = Sheets("Comps")
Set ShImpExp = Sheets("ADD.DELETE")
' Create dictionaries for Accounts and Comps
Set DicAcc = CreateObject("Scripting.Dictionary")
Set DicGrp = CreateObject("Scripting.Dictionary")
DicAcc.CompareMode = 1
DicGrp.CompareMode = 1
With ShGrid.Range("A1").CurrentRegion
' Copy Table X's data to the Data()
Set Rng = .Range(DataCell).Resize(.Rows.Count - .Range(DataCell).Row + 1, .Columns.Count - .Range(DataCell).Column + 1)
Data() = Rng.Value
' Put accounts and their rows to the dictionary
a() = Rng.EntireRow.Columns(1).Value ' Replace 1 by 4 to use D-column in Grid instead of A-column
For i = 1 To UBound(a)
DicAcc.Item(Trim(a(i, 1))) = i
Next
' Put Comp and their columns to the dictionary
a() = Rng.Offset(-1).Value
For i = 1 To UBound(a, 2)
DicGrp.Item(Trim(a(1, i))) = i
Next
End With
' Main
a() = ShImpExp.UsedRange.Resize(, 4).Value
For i = 2 To UBound(a)
s = UCase(Trim(a(i, 1))) ' "A" to add or "R" to remove
Grp = Trim(a(i, 2)) ' Comps
Acc = Trim(a(i, 3)) ' Account
a(i, 4) = Empty ' Result
If Len(Grp) > 0 And Len(Acc) > 0 Then
If Not (s = "A" Or s = "R") Then a(i, 4) = "Wrong 'A'/'R' code"
If Not DicGrp.Exists(Grp) Then a(i, 4) = IIf(Len(a(i, 4)) > 0, a(i, 4) & ", ", "") & "Composite doesn't exist"
If Not DicAcc.Exists(Acc) Then a(i, 4) = IIf(Len(a(i, 4)) > 0, a(i, 4) & ", ", "") & "Account doesn't exist"
' Update the intersected Account-Comps value in the Data()
If s = "A" Then s = "X" Else s = ""
If Len(a(i, 4)) = 0 Then
s1 = UCase(Data(DicAcc.Item(Acc), DicGrp.Item(Grp)))
If s = s1 Then
If a(i, 1) = "A" Then
a(i, 4) = "Already exists"
ElseIf a(i, 1) = "R" Then
a(i, 4) = "No X's exist to remove"
End If
Else
Data(DicAcc.Item(Acc), DicGrp.Item(Grp)) = s
a(i, 4) = "Successfully " & IIf(s = "X", "Added", "Removed")
End If
End If
End If
Next
' Update ImportExport
ShImpExp.UsedRange.Resize(, 4).Value = a()
' Update Comp
If ShGrid.FilterMode Then
With ShGrid.Rows(FreezeCellRow).EntireRow
IsHidden = .Hidden
.Hidden = False
With ThisWorkbook.CustomViews.Add("GridCustomViewName", False, True)
ShGrid.ShowAllData
Rng.Value = Data()
.Show
.Delete
End With
If IsHidden Then .Hidden = True
End With
Else
Rng.Value = Data()
End If
' Release memory of the object variables
Set DicAcc = Nothing
Set DicGrp = Nothing
End Sub
