Need help to correct code

RAJESH1960

RAJESH1960

Banned for repeated rules violations
Joined
Mar 26, 2020
Messages
2,313
Office Version
  1. 2019
Platform
  1. Windows
Hello Code Experts

I am using one of Johnnyl”s code, editing it and using it for another project. I need help in some places. Firstly, I am not able to take the range of values below the particulars column which is column C as the cells are merged. So, I added another code to copy the sheet to the working sheet and used unmerged, shifted the heading “Particulars” from B10 to C10. The range need to be edited in the code.

Secondly, here is the tough part. In the List of ledgers sheet, I want the code to avoid 4 names from the list which are Opening Balance, (as per details), 2171377 which can be different in different scenarios and finally Closing Balance. That way I will get the correct ledgers, in MasterData sheet, that I have to create.

Lastly, In the ImportMasters sheet, I am getting 5 excess rows which are empty. They will generate an error when I import the xml file to the server.
If the working sheet is avoided it would be great.
Test NA Masters.xlsm
 
Sort by date Sort by votes
Ok, I'm pretty sure I have your #2 concern fixed. In the code overwrite this area with this:

VBA Code: 
' Original
With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                    .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                      ' add unique value to DataDictionary
            End If
        Next

' Overwrite with this:
AvoidText = "Opening Balance, (as per details), 2171377, Closing Balance"
With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                If InStr(1, AvoidText, DataDictionary(DictionaryRow, 1)) = 0 Then
                    .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                      ' add unique value to DataDictionary
                End If
            End If
        Next
 
Upvote 0
Finally, to fix your issue with the 5 excess rows, you need a line somewhere that clears all the old content, except the top line. Place this somewhere. If you anticipate needing more than 10000 lines, just add to the AG's rows. Hope that helps.

VBA Code: 
Sheets("ImportMasters").Range("A3:AG10000").ClearContents
 
Upvote 0
gravanoc said:
Ok, I'm pretty sure I have your #2 concern fixed. In the code overwrite this area with this:

VBA Code: 
' Original
With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                    .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                      ' add unique value to DataDictionary
            End If
        Next

' Overwrite with this:
AvoidText = "Opening Balance, (as per details), 2171377, Closing Balance"
With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                If InStr(1, AvoidText, DataDictionary(DictionaryRow, 1)) = 0 Then
                    .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                      ' add unique value to DataDictionary
                End If
            End If
        Next
Click to expand...
I am getting an error - AvoidText variable not defined.
and the 2171377 may be any number in different scenarios. Can you just include in the code to avoid the last 3 lines and first line below the Particulars, i.e., Opening Balance.? That way I will be able to run the same code in different files.
 
Upvote 0
gravanoc said:
Finally, to fix your issue with the 5 excess rows, you need a line somewhere that clears all the old content, except the top line. Place this somewhere. If you anticipate needing more than 10000 lines, just add to the AG's rows. Hope that helps.

VBA Code: 
Sheets("ImportMasters").Range("A3:AG10000").ClearContents
Click to expand...
For this I already have a code, but where to insert I am not able to insert in the right line.
Rich (BB code): 


LastColumnLetterSheetImportMasters = Split(Cells(1, (Sheets("ImportMasters").Cells.Find("*", , xlFormulas, _
, xlByColumns, xlPrevious).Column)).Address, "$")(1)
LastRowInSheetImportMasters = Sheets("ImportMasters").Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
Sheets("ImportMasters").Range("A3:" & LastColumnLetterSheetImportMasters & LastRowInSheetImportMasters + 1).ClearContents ' Clear old data from Sheets("ImportMasters")
 
Upvote 0
My bad, you need to declare it as well.
Somewhere in your code up top type:

VBA Code: 
Dim AvoidText As String
 
Upvote 0
Did you check the hidden sheets.? The code is in the move data old code sheet. I am trying to edit that code to suit this file.
 
Upvote 0
When all the names are a match, then it msgbox should appear All Ledgers Available and stop the code from running any further. This code too is available in the Generate Master xml hidden sheet. This also has to be added in the code. But as I said where to add I have no idea.
 
Upvote 0
Ok, here is the full code. Also, I edited the AvoidText so that it always incorporates whatever the total is, since that's the number you need to avoid. Right?

VBA Code: 
Option Explicit

Sub GenerateNALedgers()
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
    Dim DictionaryRow                       As Long
    Dim SourceHeaderColumnNumber            As Long, SourceHeaderRow                    As Long, SourceLastRow  As Long
    Dim cell                                As Range
    Dim SourceLastColumnLetter              As String
    Dim AvoidText                           As String
    Dim DataDictionary                      As Variant
    Dim List_of_LedgersFormulasColumnArray  As Variant, OriginalParticularsDataArray   As Variant
    Dim SourceWS                            As Worksheet
     Sheets("Workings").Select
    Cells.Select
    Selection.Clear
    Range("A1").Select
    Sheets("List of Ledgers").Select
    Cells.Select
    Range("A5").Activate
    Sheets("Original").Select
    Cells.Select
    Selection.Copy
    Sheets("Workings").Select
    Cells.Select
    ActiveSheet.Paste
    'need to edit below line to find row with particulars which may be in any of the rows
    Rows("10:10").Select
    Application.CutCopyMode = False
    Selection.UnMerge
    Range("B10").Select
    Selection.Cut Destination:=Range("C10")
    Sheets("List of Ledgers").Select
    Columns("E:E").Select
    Selection.Clear
    Range("E6").Select
    Sheets("MasterData").Select
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("B1").Select
    Sheets("List of Ledgers").Select
    Range("E6").Select
    
    Set SourceWS = Sheets("Workings")                                                               ' <--- Set this to the source sheet
    SourceLastColumnLetter = Split(Cells(1, (SourceWS.Cells.Find("*", , xlFormulas, , _
            xlByColumns, xlPrevious).Column)).Address, "$")(1)                                      ' Get last column letter used in the source sheet
    SourceLastRow = SourceWS.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row - 1          ' Get the last source row of data minus the total row
    With SourceWS.Range("A1:" & SourceLastColumnLetter & SourceLastRow)                             ' Look through the source sheet for the header row
        Set cell = .Find("Particulars", LookIn:=xlValues)                                           '   Find the header called 'Particulars'
        If Not cell Is Nothing Then                                                                 '   If 'Particulars' is found then ...
            SourceHeaderRow = cell.Row                                                              '       Save the row # into SourceHeaderRow
            SourceHeaderColumnNumber = cell.Column                                                              '       Save the Column # into SourceHeaderColumn
        End If
    End With
    
    OriginalParticularsDataArray = SourceWS.Range(SourceWS.Cells(SourceHeaderRow + 1, SourceHeaderColumnNumber), _
            SourceWS.Cells(SourceLastRow, SourceHeaderColumnNumber))                        ' Save Data to be pasted into 2D 1 Based OriginalParticularsDataArray
    Sheets("List of Ledgers").Range("E6").Resize(UBound(OriginalParticularsDataArray, _
            1)) = OriginalParticularsDataArray                                             'Display OriginalParticularsDataArray to Sheets("List of Ledgers")
    List_of_LedgersFormulasColumnArray = Sheets("List of Ledgers").Range("F6:F" & SourceLastRow)    ' Load formula column from Sheets("List of Ledgers") to array
    DataDictionary = Sheets("List of Ledgers").Range("E6", Sheets("List of Ledgers").Cells(Rows.Count, "F").End(xlUp))  '   Create DataDictionary
    AvoidText = "Opening Balance, (as per details), Closing Balance"
    AvoidText = AvoidText & ", " & DataDictionary(UBound(DataDictionary) - 1, 1)
    
    With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                If InStr(1, AvoidText, DataDictionary(DictionaryRow, 1)) = 0 Then
                    .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                      ' add unique value to DataDictionary
                End If
            End If
        Next                                                                                                            ' Loop back
    Sheets("MasterData").Range("B2").Resize(.Count) = Application.Transpose(.keys)                              ' Display unique values on Sheets("MasterData")
   
    Dim LastColumnNumberInRow               As Long
    Dim x                                   As Long
    Dim xmlFile                             As Object
    Dim LastColumnLetterSheetImportMasters  As String
    Dim strData                             As String
    Dim strTempFile                         As String
    Sheets("ImportMasters").Range("A3:AAA10000").ClearContents
    x = Sheets("MasterData").Range("B2:B" & Sheets("MasterData").Range("B" & Rows.Count).End(xlUp).Row).Rows.Count  ' Get count of rows to write to file
    LastColumnNumberInRow = Sheets("ImportMasters").Cells(2, Sheets("ImportMasters").Columns.Count).End(xlToLeft).Column  ' Get last column number in row
    LastColumnLetterSheetImportMasters = Split(Cells(1, (Sheets("ImportMasters").Cells.Find("*", , xlFormulas, _
            , xlByColumns, xlPrevious).Column)).Address, "$")(1)                                            ' Get last column letter used in Sheets("ImportMasters")
    
    Sheets("ImportMasters").Range("A2:" & LastColumnLetterSheetImportMasters & x + 1).FillDown                  ' Create range needed to copy
    Sheets("ImportMasters").Range("A2").Resize(x, LastColumnNumberInRow).Copy
    
    strData = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("Text")                               ' Save contents into strData
    strTempFile = "C:\Users\" & Environ("username") & "\Desktop\Master.xml"
    CreateObject("Scripting.FileSystemObject").CreateTextFile(strTempFile, True).Write strData                  ' Write the data to file
    
    MsgBox ("File saved on Desktop as Master.XML.")
    End With
    Application.ScreenUpdating = True                                                                               ' Turn ScreenUpdating back on
End Sub
 
Upvote 0
After running your code after the Dim AvoidText As String, the master data sheet is just overwriting the ledgers under particulars. The particulars column from cell A2 needs to be deleted in the beginning of the code and then I will get the NA ledgers even if the number of rows increase or decrease.
 
Upvote 0
gravanoc said:
Ok, here is the full code. Also, I edited the AvoidText so that it always incorporates whatever the total is, since that's the number you need to avoid. Right?

VBA Code: 
Option Explicit

Sub GenerateNALedgers()
    Application.ScreenUpdating = False                                                              ' Turn ScreenUpdating off
    Dim DictionaryRow                       As Long
    Dim SourceHeaderColumnNumber            As Long, SourceHeaderRow                    As Long, SourceLastRow  As Long
    Dim cell                                As Range
    Dim SourceLastColumnLetter              As String
    Dim AvoidText                           As String
    Dim DataDictionary                      As Variant
    Dim List_of_LedgersFormulasColumnArray  As Variant, OriginalParticularsDataArray   As Variant
    Dim SourceWS                            As Worksheet
     Sheets("Workings").Select
    Cells.Select
    Selection.Clear
    Range("A1").Select
    Sheets("List of Ledgers").Select
    Cells.Select
    Range("A5").Activate
    Sheets("Original").Select
    Cells.Select
    Selection.Copy
    Sheets("Workings").Select
    Cells.Select
    ActiveSheet.Paste
    'need to edit below line to find row with particulars which may be in any of the rows
    Rows("10:10").Select
    Application.CutCopyMode = False
    Selection.UnMerge
    Range("B10").Select
    Selection.Cut Destination:=Range("C10")
    Sheets("List of Ledgers").Select
    Columns("E:E").Select
    Selection.Clear
    Range("E6").Select
    Sheets("MasterData").Select
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("B1").Select
    Sheets("List of Ledgers").Select
    Range("E6").Select
   
    Set SourceWS = Sheets("Workings")                                                               ' <--- Set this to the source sheet
    SourceLastColumnLetter = Split(Cells(1, (SourceWS.Cells.Find("*", , xlFormulas, , _
            xlByColumns, xlPrevious).Column)).Address, "$")(1)                                      ' Get last column letter used in the source sheet
    SourceLastRow = SourceWS.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row - 1          ' Get the last source row of data minus the total row
    With SourceWS.Range("A1:" & SourceLastColumnLetter & SourceLastRow)                             ' Look through the source sheet for the header row
        Set cell = .Find("Particulars", LookIn:=xlValues)                                           '   Find the header called 'Particulars'
        If Not cell Is Nothing Then                                                                 '   If 'Particulars' is found then ...
            SourceHeaderRow = cell.Row                                                              '       Save the row # into SourceHeaderRow
            SourceHeaderColumnNumber = cell.Column                                                              '       Save the Column # into SourceHeaderColumn
        End If
    End With
   
    OriginalParticularsDataArray = SourceWS.Range(SourceWS.Cells(SourceHeaderRow + 1, SourceHeaderColumnNumber), _
            SourceWS.Cells(SourceLastRow, SourceHeaderColumnNumber))                        ' Save Data to be pasted into 2D 1 Based OriginalParticularsDataArray
    Sheets("List of Ledgers").Range("E6").Resize(UBound(OriginalParticularsDataArray, _
            1)) = OriginalParticularsDataArray                                             'Display OriginalParticularsDataArray to Sheets("List of Ledgers")
    List_of_LedgersFormulasColumnArray = Sheets("List of Ledgers").Range("F6:F" & SourceLastRow)    ' Load formula column from Sheets("List of Ledgers") to array
    DataDictionary = Sheets("List of Ledgers").Range("E6", Sheets("List of Ledgers").Cells(Rows.Count, "F").End(xlUp))  '   Create DataDictionary
    AvoidText = "Opening Balance, (as per details), Closing Balance"
    AvoidText = AvoidText & ", " & DataDictionary(UBound(DataDictionary) - 1, 1)
   
    With CreateObject("Scripting.Dictionary")
        For DictionaryRow = 1 To UBound(DataDictionary)                                                                 ' Loop through each row of DataDictionary
            If Not .Exists(DataDictionary(DictionaryRow, 1)) And IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If uniue value found &  ...
'                                                                                                                       ' Error found in column to the right then ...
                If InStr(1, AvoidText, DataDictionary(DictionaryRow, 1)) = 0 Then
                    .Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2))                      ' add unique value to DataDictionary
                End If
            End If
        Next                                                                                                            ' Loop back
    Sheets("MasterData").Range("B2").Resize(.Count) = Application.Transpose(.keys)                              ' Display unique values on Sheets("MasterData")
  
    Dim LastColumnNumberInRow               As Long
    Dim x                                   As Long
    Dim xmlFile                             As Object
    Dim LastColumnLetterSheetImportMasters  As String
    Dim strData                             As String
    Dim strTempFile                         As String
    Sheets("ImportMasters").Range("A3:AAA10000").ClearContents
    x = Sheets("MasterData").Range("B2:B" & Sheets("MasterData").Range("B" & Rows.Count).End(xlUp).Row).Rows.Count  ' Get count of rows to write to file
    LastColumnNumberInRow = Sheets("ImportMasters").Cells(2, Sheets("ImportMasters").Columns.Count).End(xlToLeft).Column  ' Get last column number in row
    LastColumnLetterSheetImportMasters = Split(Cells(1, (Sheets("ImportMasters").Cells.Find("*", , xlFormulas, _
            , xlByColumns, xlPrevious).Column)).Address, "$")(1)                                            ' Get last column letter used in Sheets("ImportMasters")
   
    Sheets("ImportMasters").Range("A2:" & LastColumnLetterSheetImportMasters & x + 1).FillDown                  ' Create range needed to copy
    Sheets("ImportMasters").Range("A2").Resize(x, LastColumnNumberInRow).Copy
   
    strData = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("Text")                               ' Save contents into strData
    strTempFile = "C:\Users\" & Environ("username") & "\Desktop\Master.xml"
    CreateObject("Scripting.FileSystemObject").CreateTextFile(strTempFile, True).Write strData                  ' Write the data to file
   
    MsgBox ("File saved on Desktop as Master.XML.")
    End With
    Application.ScreenUpdating = True                                                                               ' Turn ScreenUpdating back on
End Sub
Click to expand...
Rich (BB code): 
Sheets("MasterData").Range("B2").Resize(.Count) = Application.Transpose(.keys)                              ' Display unique values on Sheets("MasterData")
Error at the above line. Run time error 13. Type mismatch.
I changed the list of ledgers by adding the NA list to List of Ledgers. This way all the ledgers are a match. So, the code should display the msgbox as All ledgers Available and stop executing the rest of the code.
Please refer the hidden sheets. All the answers are there. I have used the same code in different projects and they are running perfectly. As the format is different in this project, I am a bit confused.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Locked
  • Question Question
Severe Amateur needs code to pull data from multiple sheets into one master
Replies
1
Views
135
Peter_SSs
Peter_SSs
L
  • Question Question
VBA code-Assistance Sought
Replies
2
Views
161
Latlonchy
L
A
  • Question Question
Excel - looking up data with multiple criteria from table/array, date must be same or nearest before the target cell
Replies
8
Views
813
Peter_SSs
Peter_SSs
A
  • Question Question
Modifying code for message box on userform based on selected combobox
Replies
0
Views
172
Ali M
A
P
  • Solved
VBA Loop and Msgbox issue
Replies
3
Views
121
saboh12617
S

Forum statistics

Threads
1,226,798
Messages
6,193,065
Members
453,773
Latest member
bclever07

Share this page

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
Back
Top