• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

I can't quite get this working???

Hamish

Member
I can't quite get this working???
Code:
Option Explicit

Sub GetFiles()

Dim strEst1 As String
Dim strEst2 As String

strEst1 = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", Title:="Select the FIRST estimate")
strEst2 = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", Title:="Select the SECOND estimate")

If strEst1 <> "False" And strEst2 <> "False" Then
Workbooks.Open strEst1, False 'This is workbooks.count - 2
BreakAllLinks ActiveWorkbook

Workbooks.Open strEst2, False 'This is workbooks.count - 1
BreakAllLinks ActiveWorkbook

Workbooks.Add 'This is workbooks.count

Workbooks(Workbooks.Count - 2).Worksheets("ss bom").ListObjects(1).Unlist
Workbooks(Workbooks.Count - 2).Worksheets("ss bom").Range("a1").CurrentRegion.Copy
ActiveCell.PasteSpecial xlPasteColumnWidths
ActiveCell.PasteSpecial xlPasteValuesAndNumberFormats

Dim newHeadings As Integer

newHeadings = ActiveWorkbook.Worksheets(1).Range("a1").End(xlDown).Offset(1, 0).Row

Workbooks(Workbooks.Count - 1).Worksheets("ss bom").ListObjects(1).Unlist
Workbooks(Workbooks.Count - 1).Worksheets("ss bom").Range("a1").CurrentRegion.Copy
ActiveCell.End(xlDown).Offset(1, 0).Select

ActiveCell.PasteSpecial xlPasteColumnWidths
ActiveCell.PasteSpecial xlPasteValuesAndNumberFormats

Rows(newHeadings).Delete

Workbooks(Workbooks.Count - 2).Close savechanges:=False
Workbooks(Workbooks.Count - 1).Close savechanges:=False

Range("a1").Select

ActiveSheet.ListObjects.Add(xlSrcRange, Range("a1").CurrentRegion, , xlYes).Name = _
"CombinedEstimates"

End If



End Sub
 
Last edited by a moderator:
It appears that you are missing a subroutine or function
The line
BreakAllLinks ActiveWorkbook
appears to be calling a subroutrine or function called BreakAllLinks and passing the active workbook to it to I assume break all its links

Everything else appears to be ok

It is very hard to comment without some sample files and knowing what this is meant to achieve

Can you post the sample files?
 
Hi Hui,

I got the first section of code sorted, I cannot seem to get this piece of code working? I am trying to add 2 estimates together, then filter the estimates, remove duplicate items, then make the grouped items positive or negative based on a condition (being the name of each compared row in the estimates)

My code breaks here (red, bold line);
If Len(strRows) <> 0 Then
ActiveSheet.ListObjects(strTableName).Unlist

'Delete all duplicate rows
Range(strRows).Delete

Full code is here;

Code:
Option Explicit
Private strRows As String

Sub blah()

    strRows = ""
  
    'Define a list object variable - this will allow us to refer to
    'the 'Table' we created on Sheet1
    Dim lstData As ListObject
    Dim strTableName As String
  
    strTableName = "CombinedEstimates" ' SET this to whatever name is specified in the
                                       ' basCombineEstimates module
  
    Set lstData = ActiveWorkbook.Worksheets("Sheet1").ListObjects(strTableName)

    'Cut and paste all rows of both worksheets labelled "ssbom"
  
    'sort all items together by cost center code and then by item number in ascending order
    lstData.Sort.SortFields.Clear
    lstData.Sort.SortFields.Add _
        Key:=Range(strTableName & "[Cost centre]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    lstData.Sort.SortFields.Add _
        Key:=Range(strTableName & "[Item number]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortTextAsNumbers
    With lstData.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
  
    'for each item number 'group' do the following
  
    'Select C2 - this is the first item number listed
    Cells(2, 3).Select
  
    'Repeat until you get to an empty cell
    'NOTE: If a row is missing an item number, the code WILL stop
    Do Until ActiveCell.Value = ""
  
        'define first row of group
      
        Dim strCurrentItem As String 'This stores the current item number
      
        Dim strNextItem As String 'This stores the group number for the
                                  'cell below the one we are currently in
      
        Dim intStartingRow As Integer 'This stores the row belonging to the current item no.
      
        Dim intLastRow As Integer 'This stores the last row of that group of item numbers
      
        intStartingRow = ActiveCell.Row
      
        Do
            strCurrentItem = ActiveCell.Value
            strNextItem = ActiveCell.Offset(1, 0).Value
            ActiveCell.Offset(1, 0).Select 'Move down to the cell below the current cell
        Loop While strCurrentItem = strNextItem 'Keep going while the two item numbers match
      
        'Now we are here, the item numbers no longer match
        'Set last row to be the row above me
        intLastRow = ActiveCell.Offset(-1, 0).Row
      
        If intStartingRow <> intLastRow Then
          
            Dim intCounter As Integer
          
            'get quantity from starting row
            Dim sngQuantity As Single
            sngQuantity = Cells(intStartingRow, 5).Value
          
            'Get price to starting row
            Dim sngPrice As Single
            sngPrice = Cells(intStartingRow, 7).Value
          
            'loop from starting row to ending row
            For intCounter = intStartingRow To intLastRow
                'If quantity or price are different than our 'reference' row (which is the first in the group)
                If Cells(intCounter, 5).Value <> sngQuantity Or Cells(intCounter, 7).Value <> sngPrice Then
                    'Check if inspire and negate
                    If Cells(intStartingRow, 9).Value = "Inspire" Then
                        Cells(intStartingRow, 5).Value = Cells(intStartingRow, 5).Value * -1
                    End If
                Else
                    'Are we on the reference row? If so, don't add it to the list just yet.
                    If intCounter <> intStartingRow Then
                        AddDuplicateRow intStartingRow, intCounter
                    End If
                End If
            Next
          
            'AddDuplicateRow intCounter, intCounter
        End If
    Loop
  
    If Len(strRows) <> 0 Then
        ActiveSheet.ListObjects(strTableName).Unlist
  
        'Delete all duplicate rows
        Range(strRows).Delete
  
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("a1").CurrentRegion, , xlYes).Name = _
            strTableName
    End If
  
        Range("a1").Select
    'Sum totals as previously done and display difference
    
End Sub

Sub AddDuplicateRow(intStart As Integer, intEnd As Integer)

    'Check to see if there are any rows currently stored in the variable
    If Len(strRows) = 0 Then
        strRows = intStart & ":" & intEnd
    Else
        strRows = strRows & "," & intStart & ":" & intEnd
    End If
  
    Debug.Print strRows

End Sub
 
Last edited by a moderator:
The rows to be deleted all appear correctly in the immediate window howevr they are not being removed.
 
strRows is defined at the top of the code as
strRows = ""

But it isn't defined as a range anywhere

in the line
Range(strRows).Delete

The Range object requires a valid range definition and in your case "" isn't valid
 
Hi Hamish ,

When the code errors out , can you observe the following ?

1. That the table has been converted to a range

2. Display the value of strRows by typing in the Immediate window :

?strRows

Narayan
 
I left the rows as "" in the hope they would remain open, the strRows show up fine in the immediate window. How can I get them to be recognised and subsequent code to run on these lines?

Thanks guys
 
Hi Hamish ,

Instead of giving generalities , can you please give specifics ?

When the code errors out , display the content of the variable strRows , as suggested in my earlier post.

It is possible that there may be a limit of 255 characters , and the length of the string variable strRows is exceeding that. Accurate data can expedite correct decisions.

Narayan
 
Hi Hamish ,

The problem is clear ; the string length is exceeding the limit of 255 characters ; the final value of strRows is extremely high ; if you reduce this length to the following :

2:3,4:5,6:7,8:9,10:11,12:13,16:17,18:19,20:21,22:23,26:27,28:29,30:31,32:33,34:35,38:39,40:41,42:43,44:45,50:51,52:53,54:55,56:57,58:59,62:63,66:67,73:74,75:76,80:81,84:85,86:87,90:91,92:93,94:95,96:97,98:99,100:101,104:105,108:109,110:111,112:113,114:115

it works.

Any more than this , and the delete statement does not work.

Narayan
 
Hi Hamish ,

You need to check the length of strRows each time the AddDuplicateRow procedure is called ; if the length threatens to exceed 255 , the procedure should return , and the Delete method should be executed on this value of strRows.

The AddDuplicateRow procedure will have to be rewritten to use a third parameter , a Boolean , which will tell the calling procedure whether it is done or not. It will be done when all the rows till intEnd have been processed.

The calling procedure , in turn , will have to call the AddDuplicateRow procedure within a loop , as long as the third parameter is not TRUE.

Narayan
 
Hi Narayan & Hui,

Thanks a heap for your help! I'm still very new to VBA and I'm struggling to put this advice into motion. How would the best way to write this be?

Thanks in advance.
 
Hi Hamish ,

I am not able to open the first file Book 1.xlsx ; I have been able to download and open the second file but running the procedure on the data does not generate any error.

Is it possible for you to upload a file which generates an error when you run the procedure , so that when the code is revised and the error is not generated , it will be some sort of proof that the code is an improvement ?

Narayan
 
Hi Hamish ,

No problem ; but the solution is proving to be a little more difficult than I thought. I'll try to upload the revised code today.

Narayan
 
Hi Hamish ,

See the file.

I have not really gone through the main procedure ; all that I have done is modify the AddDuplicateRow subroutine.

Please test it on as much sample data as possible ; the problem is that the main procedure is not keeping track of the values of the variables intStartingRow and intCounter ; thus , when there are 3 rows which are duplicates , as is happening with rows 470 , 471 and 472 , the first call to the AddDuplicateRow subroutine adds the text 470:471 to the strRows variable ; the next call adds the text 470:472 to the strRows variable.

When this text string is finally passed to the statement :

Range(strRows).Delete

it generates an error , saying that the command cannot be carried out on overlapping rows.

I have worked around this problem , but I am not sure it is fool-proof.

If you can go through the code and verify that it will work always , that will be nice.

Narayan
 

Attachments

  • Failed spreadsheet_to_be_tested.xlsm
    79.1 KB · Views: 3
Back
Top