Posts by Tom Rowe

Tom Rowe · Oct 22nd 2020

Hi Rory,

Yes I have discovered that VBA Code Obsfucation is not an exact science.

In the project I was obfuscating I had an onLoad event. Which I don't actually do anything with but always include if I want to do so in the future.

Code

<customUI onLoad="ConwaysGameOfLifeRibbonOnLoad" xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon startFromScratch="false">
<tabs>
<tab id="conways_game_of_life" label="Conway's Game of Life">

So I deleted it and you guessed it I no longer get the two 400 Errors. So most probably as you suggested the Ribbon was still executing the callback. The reason there were two was I have two instances of the project to obsfucate open. The initial a Read Only which I then do a SaveAs for the obsfucated version.

On an even happier note the Conway's Game of Life project obsfucated successfully on my latest VBA Code Obsfucator version and all the code worked perfectly.

Regards,

Tom Rowe

Tom Rowe · Oct 21st 2020

Hi Rory,

Regarding : Curious as to how the ribbon callbacks could work if you give all procedures random names?

By changing the callbacks manually in the Ribbon XML Files to the random names which I keep a log of. Or alternatively don't change them. But haven't got the project to the state yet where I can successfully compile and run the obsfucated code.

Regards,

Tom Rowe.

Tom Rowe · Oct 20th 2020

Hi,

I am currently working on a a project to obsfucate VBA code I use the following code from the late Chip Pearson's article on 'Programming The VBA Editor'.

Chip Pearson - Programming The VBA Editor

http://www.cpearson.com/excel/vbe.aspx

to get the project modules which I then loop through to obsfucate the code by generating random names for the projects variables and procedures.

Code

Public Sub GetModules(objWorkbookToListModules As Workbook)

' +--[ GetModules ]-----------------------------------------------------------------+
' |  This code stores the passed objWorkbookToListModules modules, their types and  |
' |  obsfucated name in array arrModules.                                           |
' |                                                                                 |
' |  Note : The function uses the Function ComponentTypeToString.                   |
' +---------------------------------------------------------------------------------+

Dim objVBComponent As VBIDE.VBComponent
Dim objVBProject As VBIDE.VBProject
Dim strVBComponentType As String
        
Set objVBProject = objWorkbookToListModules.VBProject
    
For Each objVBComponent In objVBProject.VBComponents
    ReDim Preserve arrModules(intModuleCount)
  
    Select Case objVBComponent.Type
          Case vbext_ct_ActiveXDesigner
              strVBComponentType = "ActiveX"
          Case vbext_ct_ClassModule
              strVBComponentType = "Class"
          Case vbext_ct_Document
              strVBComponentType = "Document"
          Case vbext_ct_MSForm
              strVBComponentType = "UserForm"
          Case vbext_ct_StdModule
              strVBComponentType = "Code"
          Case Else
              strVBComponentType = "Unknown"
    End Select
 
    arrModules(intModuleCount).strModuleObfuscatedName = "Obsfucated_" & strVBComponentType & "_Module" & Trim(Str(intModuleCount))
    arrModules(intModuleCount).strModuleOriginalName = objVBComponent.Name
    arrModules(intModuleCount).strModuleType = ComponentTypeToString(objVBComponent.Type)
    
    intModuleCount = intModuleCount + 1
Next

Set objVBProject = Nothing

End Sub

Display More

The code is called by...

Code

GetModules objWorkbookToObsfucate

This works fine, until I try obsfucating a project that has a custom ribbon. When I receive two 400 Errors when ThisWorkbook is accessed. If I remove the Custom Ribbon XML I don't get the errors. The ribbon code for the project all works perfectly. So failing to understand why I am getting the 400 Errors ?

Probably a bit of a long shot but was wondering if anyone has experienced a similar problem ?

Regards,

Tom Rowe

Tom Rowe · Sep 29th 2019

Hi,

Why bother to complicate things by using code ?

Simply copy your Excel File to Google Drive then open with Google Sheets and the data will be converted automatically.

Regards,

Tom Rowe...

Tom Rowe · Jun 13th 2019

Hi,

Simply set the Textbox EnterKeyBehavior property to True.

See...

https://docs.microsoft.com/en-gb/office/vba/Language/Reference/User-Interface-Help/enterkeybehavior-property

Regards,

Tom Rowe...

Tom Rowe · Jun 12th 2019

Hi,

So what is going wrong with your code ?

Also you are more likely to get some help if you post a copy of your spread sheet.

Regards,

Tom Rowe...

Tom Rowe · Jun 12th 2019

Hi,

rngFoundCell is not nothing is determined by the .Find which returns nothing if the What:= item is not found.

I have updated the code for you to handle the Job #. Also the code is now more generic so you can pass a worksheet object to the subroutinest specifying what Worksheet you want. I also found a minor bug with the sort routine in that it was using the wrong worksheet to set the Last Row on this line...

Code

.SetRange Range("A2:C" & Trim(Str(LastRow(objOrderWorksheet, 1))))

Which may have been causing your problem.

I have attached an updated workbook for you.

Regards,

Tom Rowe...

The updated VBA Code follows...

Code

Option Explicit


Public Sub AddBestCombinationRowToOrder(objOrderWorksheet As Worksheet)


Dim blnCombinationMatched As Boolean
Dim intOrder As Integer
Dim lngRow As Long
Dim lngRowUndo As Long
Dim strAddComment As String
Dim strFind As String
Dim strJobNumber As String
Dim rngFoundCell As Range
Dim vntArrayBestCombination As Variant
Dim vntBestCombination As Variant


' Create header.
objOrderWorksheet.Cells(1, "C") = "Best Combination Row "


' Loop through the best combinations.
For lngRow = 2 To LastRow(wsBestCombinations, 1)
    vntBestCombination = Replace(wsBestCombinations.Cells(lngRow, "A"), "[", "")
    vntArrayBestCombination = Split(vntBestCombination, "]")
    ' Match the combinations with the order lengths.
    For intOrder = LBound(vntArrayBestCombination) To UBound(vntArrayBestCombination)
        With objOrderWorksheet
             If Trim(vntArrayBestCombination(intOrder)) <> "" Then
                Set rngFoundCell = .Columns("B").Find(What:=Trim(vntArrayBestCombination(intOrder)), After:=.Cells(2, 2), LookIn:=xlFormulas, _
                                   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
             
                If Not rngFoundCell Is Nothing Then
                   ' Tag and highlight the order.
                   rngFoundCell.Value = rngFoundCell.Value & " X"
                   rngFoundCell.Interior.Color = vbYellow
                   objOrderWorksheet.Cells(rngFoundCell.Row, "C") = lngRow
                   strAddComment = "Combination: " & vbCrLf & wsBestCombinations.Cells(lngRow, "A") & vbCrLf & "Wastage: " & vbCrLf & _
                                    wsBestCombinations.Cells(lngRow, "C") & " %"
                   objOrderWorksheet.Cells(rngFoundCell.Row, "C").AddComment (strAddComment)
                Else
                   blnCombinationMatched = False
                End If
             End If
       End With
    Next
    
    If blnCombinationMatched = False Then
       ' Undo the Tag and highlight for the order.
       For lngRowUndo = 2 To LastRow(wsOrder, 1)
           If objOrderWorksheet.Cells(lngRowUndo, "C") = lngRow Then
              objOrderWorksheet.Cells(lngRowUndo, "B") = Replace(objOrderWorksheet.Cells(lngRowUndo, "B"), " X", "")
              objOrderWorksheet.Cells(lngRowUndo, "B").Interior.Color = xlNone
              objOrderWorksheet.Cells(lngRowUndo, "C") = ""
              objOrderWorksheet.Cells(lngRowUndo, "C").ClearComments
            End If
       Next
        
       blnCombinationMatched = True
    End If
Next


' Format objOrderWorksheet.
objOrderWorksheet.Select
objOrderWorksheet.Rows("1:1").Select
Selection.Font.Bold = True
objOrderWorksheet.Cells.Select
Selection.Columns.AutoFit


' Sort objOrderWorksheet.
objOrderWorksheet.Columns("C:C").Select
objOrderWorksheet.Sort.SortFields.Clear
objOrderWorksheet.Sort.SortFields.Add2 Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With objOrderWorksheet.Sort
    .SetRange Range("A2:C" & Trim(Str(LastRow(objOrderWorksheet, 1))))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


End Sub


Function BestCombinations(objOrderWorksheet As Worksheet, intStockPieceLengthmm As Integer, intNoOfItemsToCutFromStockPiece As Integer, strStock As String)


' Change if you require less wastage.
Const MaximumWastePercent = 15
Dim intField As Integer
Dim intTotalLengthToCutFromStockmm As Integer
Dim intTable As Integer
Dim intWaste As Integer
Dim lngBestCombinationCount As Long
Dim lngRecordCount As Long
Dim lngRow As Long
Dim vntWastePercent As Variant
Dim objConnection As Object
Dim objRecordset As Object
Dim strCombination As String
Dim strFieldValue As String
Dim strSQL As String


' Delete existing data.
wsBestCombinations.Select
wsBestCombinations.Cells.Select
Selection.Delete Shift:=xlUp
' Create headings.
wsBestCombinations.Cells(1, "A") = "Combination"
wsBestCombinations.Cells(1, "B") = "Combination Length"
wsBestCombinations.Cells(1, "C") = "Stock " & strStock & " Wastage %"


' Create the SQL Tables for the cross join query.
objOrderWorksheet.Select
objOrderWorksheet.Columns("B").Select
Selection.Copy
For intTable = 1 To intNoOfItemsToCutFromStockPiece
    objOrderWorksheet.Columns(intTable + 2).Select
    objOrderWorksheet.Paste
Next


Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")


With objConnection
     .Provider = "Microsoft.ACE.OLEDB.12.0"
     .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
     .Open
End With


' Build the SQL cross join query.
' A cross join (or cartesian join) is used when you wish to create combination of every row from two or more tables.  All row combinations
' are included in the result.
For intTable = 1 To intNoOfItemsToCutFromStockPiece
    strSQL = strSQL & "[" & ColumnLetter(intTable + 2) & ":" & ColumnLetter(intTable + 2) & "]"
    If intTable <> intNoOfItemsToCutFromStockPiece Then strSQL = strSQL & ", "
Next


strSQL = "SELECT * FROM " & strSQL
'Debug.Print strSQL


' Run the query.
objRecordset.Open strSQL, objConnection


lngRow = 2


' Loop through the record set
Do Until objRecordset.EOF
   On Error GoTo ErrorBestCombinations
   For intField = 0 To objRecordset.Fields.Count - 1
       intTotalLengthToCutFromStockmm = intTotalLengthToCutFromStockmm + objRecordset(intField)
       strCombination = strCombination & "[" & objRecordset(intField) & "] "
   Next
   
   ' Check if the combination is within the allowable MaximumWastePercent if so then output it.
   intWaste = intStockPieceLengthmm - intTotalLengthToCutFromStockmm
   
   If intWaste < 0 Then
      ' The stock length has been exceeded
   Else
      ' Work out the waste percentage.
      vntWastePercent = Round((intWaste / intStockPieceLengthmm) * 100, 3)


      If vntWastePercent <= MaximumWastePercent Then
         ' The combination is within the acceptable wastage limit so output it.
         lngBestCombinationCount = lngBestCombinationCount + 1
         wsBestCombinations.Cells(lngRow, "A") = strCombination
         wsBestCombinations.Cells(lngRow, "B") = intTotalLengthToCutFromStockmm
         wsBestCombinations.Cells(lngRow, "C") = vntWastePercent
         
         lngRow = lngRow + 1
      End If
   End If
   
   ' Set the variables ready for the next record.
   intTotalLengthToCutFromStockmm = 0
   strCombination = ""


   objRecordset.MoveNext
   
   lngRecordCount = lngRecordCount + 1
Loop


objRecordset.Close
objConnection.Close


Set objRecordset = Nothing
Set objConnection = Nothing


' Remove the duplicate combinations.
wsBestCombinations.Columns("A:A").Select
wsBestCombinations.Range("A1:C" & LastRow(wsBestCombinations, 1)).RemoveDuplicates Columns:=1, Header:=xlYes


' Format wsBestCombinations.
wsBestCombinations.Select
wsBestCombinations.Rows("1:1").Select
Selection.Font.Bold = True
wsBestCombinations.Cells.Select
Selection.Columns.AutoFit


' Sort wsBestCombinations.
wsBestCombinations.Columns("C:C").Select
wsBestCombinations.Sort.SortFields.Clear
wsBestCombinations.Sort.SortFields.Add2 Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsBestCombinations.Sort
    .SetRange Range("A2:C" & Trim(Str(LastRow(wsBestCombinations, 1))))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


' Delete the SQL Cross Join Query tables for each item to cut from the stock piece.
For intTable = intNoOfItemsToCutFromStockPiece To 1 Step -1
    objOrderWorksheet.Columns(intTable + 1).Delete Shift:=xlToLeft
Next


MsgBox "Finished analysing the best combinations." & vbCrLf & _
       Trim(Str(lngRecordCount)) & " possible combinations were analysed." & vbCrLf & _
       "Resulting in " & Trim(Str(lngBestCombinationCount)) & " possible best combinations.", _
       vbOKOnly + vbInformation, "Best Combinations Analysis Complete"


Exit Function


ErrorBestCombinations:
'Debug.Print "Error Number : "; Err.Number
'Debug.Print Err.Description
Resume Next


End Function


Public Function ColumnLetter(intColumnNumber As Integer) As String


If intColumnNumber > 26 Then
   ' 1st character: Subtract 1 to map the characters to 0-25,
   ' but you don't have to remap back to 1-26
   ' after the 'Int' operation since columns
   ' 1-26 have no prefix letter
   ' 2nd character: Subtract 1 to map the characters to 0-25,
   ' but then must remap back to 1-26 after
   ' the 'Mod' operation by adding 1 back in
   ' (included in the '65')
    ColumnLetter = Chr(Int((intColumnNumber - 1) / 26) + 64) & _
    Chr(((intColumnNumber - 1) Mod 26) + 65)
Else
   ' Columns A-Z
   ColumnLetter = Chr(intColumnNumber + 64)
End If


End Function


Public Function LastRow(objWorkSheetFindLastRow As Worksheet, intColFindLastRow As Integer) As Long


' Ensure that the column being passed is populated for all rows for the correct last row to be returned.
With objWorkSheetFindLastRow
     LastRow = .Cells(.Rows.Count, intColFindLastRow).End(xlUp).Row
End With


End Function


Public Sub PopulateOrderCombinations(objOrderWorksheet As Worksheet, objWorksheetToPopulate As Worksheet)


Dim lngBestCombinationRow As Long
Dim lngRow As Long
Dim lngPopulateRow As Long
Dim strJobNumber As String


' Delete existing data.
objWorksheetToPopulate.Select
objWorksheetToPopulate.Cells.Select
Selection.Delete Shift:=xlUp
' Create headings.
objWorksheetToPopulate.Cells(1, "A") = "Order Combinations"


lngBestCombinationRow = objOrderWorksheet.Cells(2, "C")
lngPopulateRow = 2


' Loop through the Best Combination Row column.
For lngRow = 2 To LastRow(objOrderWorksheet, 3)
    If objOrderWorksheet.Cells(lngRow, "C") = lngBestCombinationRow Then
       strJobNumber = strJobNumber & objOrderWorksheet.Cells(lngRow, "A") & ", "
    Else
       objWorksheetToPopulate.Cells(lngPopulateRow, "A") = wsBestCombinations.Cells(lngBestCombinationRow, "A") & " Job #s " & strJobNumber
       strJobNumber = objOrderWorksheet.Cells(lngRow, "A") & ", "
       lngPopulateRow = lngPopulateRow + 1
    End If
    
    lngBestCombinationRow = objOrderWorksheet.Cells(lngRow, "C")
Next


objWorksheetToPopulate.Cells(lngPopulateRow, "A") = wsBestCombinations.Cells(lngBestCombinationRow, "A") & " Job #s " & strJobNumber


' Format objWorksheetToPopulate.
objWorksheetToPopulate.Select
objWorksheetToPopulate.Rows("1:1").Select
Selection.Font.Bold = True
objWorksheetToPopulate.Cells.Select
Selection.Columns.AutoFit


End Sub


Sub TestCombinations()


' 6096mm (20ft)
' 12192mm (40ft)
' 18288mm (60ft)


Application.ScreenUpdating = False
' Change parameters to suit the required analysis.
BestCombinations wsOrder, 12192, 4, "40ft (12192mm)"
AddBestCombinationRowToOrder wsOrder
PopulateOrderCombinations wsOrder, wsOrderCombinations
Application.ScreenUpdating = True


End Sub


Option Explicit


Public Sub AddBestCombinationRowToOrder(objOrderWorksheet As Worksheet)


Dim blnCombinationMatched As Boolean
Dim intOrder As Integer
Dim lngRow As Long
Dim lngRowUndo As Long
Dim strAddComment As String
Dim strFind As String
Dim strJobNumber As String
Dim rngFoundCell As Range
Dim vntArrayBestCombination As Variant
Dim vntBestCombination As Variant


' Create header.
objOrderWorksheet.Cells(1, "C") = "Best Combination Row "


' Loop through the best combinations.
For lngRow = 2 To LastRow(wsBestCombinations, 1)
    vntBestCombination = Replace(wsBestCombinations.Cells(lngRow, "A"), "[", "")
    vntArrayBestCombination = Split(vntBestCombination, "]")
    ' Match the combinations with the order lengths.
    For intOrder = LBound(vntArrayBestCombination) To UBound(vntArrayBestCombination)
        With objOrderWorksheet
             If Trim(vntArrayBestCombination(intOrder)) <> "" Then
                Set rngFoundCell = .Columns("B").Find(What:=Trim(vntArrayBestCombination(intOrder)), After:=.Cells(2, 2), LookIn:=xlFormulas, _
                                   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
             
                If Not rngFoundCell Is Nothing Then
                   ' Tag and highlight the order.
                   rngFoundCell.Value = rngFoundCell.Value & " X"
                   rngFoundCell.Interior.Color = vbYellow
                   objOrderWorksheet.Cells(rngFoundCell.Row, "C") = lngRow
                   strAddComment = "Combination: " & vbCrLf & wsBestCombinations.Cells(lngRow, "A") & vbCrLf & "Wastage: " & vbCrLf & _
                                    wsBestCombinations.Cells(lngRow, "C") & " %"
                   objOrderWorksheet.Cells(rngFoundCell.Row, "C").AddComment (strAddComment)
                Else
                   blnCombinationMatched = False
                End If
             End If
       End With
    Next
    
    If blnCombinationMatched = False Then
       ' Undo the Tag and highlight for the order.
       For lngRowUndo = 2 To LastRow(wsOrder, 1)
           If objOrderWorksheet.Cells(lngRowUndo, "C") = lngRow Then
              objOrderWorksheet.Cells(lngRowUndo, "B") = Replace(objOrderWorksheet.Cells(lngRowUndo, "B"), " X", "")
              objOrderWorksheet.Cells(lngRowUndo, "B").Interior.Color = xlNone
              objOrderWorksheet.Cells(lngRowUndo, "C") = ""
              objOrderWorksheet.Cells(lngRowUndo, "C").ClearComments
            End If
       Next
        
       blnCombinationMatched = True
    End If
Next


' Format objOrderWorksheet.
objOrderWorksheet.Select
objOrderWorksheet.Rows("1:1").Select
Selection.Font.Bold = True
objOrderWorksheet.Cells.Select
Selection.Columns.AutoFit


' Sort objOrderWorksheet.
objOrderWorksheet.Columns("C:C").Select
objOrderWorksheet.Sort.SortFields.Clear
objOrderWorksheet.Sort.SortFields.Add2 Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With objOrderWorksheet.Sort
    .SetRange Range("A2:C" & Trim(Str(LastRow(objOrderWorksheet, 1))))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


End Sub


Function BestCombinations(objOrderWorksheet As Worksheet, intStockPieceLengthmm As Integer, intNoOfItemsToCutFromStockPiece As Integer, strStock As String)


' Change if you require less wastage.
Const MaximumWastePercent = 15
Dim intField As Integer
Dim intTotalLengthToCutFromStockmm As Integer
Dim intTable As Integer
Dim intWaste As Integer
Dim lngBestCombinationCount As Long
Dim lngRecordCount As Long
Dim lngRow As Long
Dim vntWastePercent As Variant
Dim objConnection As Object
Dim objRecordset As Object
Dim strCombination As String
Dim strFieldValue As String
Dim strSQL As String


' Delete existing data.
wsBestCombinations.Select
wsBestCombinations.Cells.Select
Selection.Delete Shift:=xlUp
' Create headings.
wsBestCombinations.Cells(1, "A") = "Combination"
wsBestCombinations.Cells(1, "B") = "Combination Length"
wsBestCombinations.Cells(1, "C") = "Stock " & strStock & " Wastage %"


' Create the SQL Tables for the cross join query.
objOrderWorksheet.Select
objOrderWorksheet.Columns("B").Select
Selection.Copy
For intTable = 1 To intNoOfItemsToCutFromStockPiece
    objOrderWorksheet.Columns(intTable + 2).Select
    objOrderWorksheet.Paste
Next


Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")


With objConnection
     .Provider = "Microsoft.ACE.OLEDB.12.0"
     .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
     .Open
End With


' Build the SQL cross join query.
' A cross join (or cartesian join) is used when you wish to create combination of every row from two or more tables.  All row combinations
' are included in the result.
For intTable = 1 To intNoOfItemsToCutFromStockPiece
    strSQL = strSQL & "[" & ColumnLetter(intTable + 2) & ":" & ColumnLetter(intTable + 2) & "]"
    If intTable <> intNoOfItemsToCutFromStockPiece Then strSQL = strSQL & ", "
Next


strSQL = "SELECT * FROM " & strSQL
'Debug.Print strSQL


' Run the query.
objRecordset.Open strSQL, objConnection


lngRow = 2


' Loop through the record set
Do Until objRecordset.EOF
   On Error GoTo ErrorBestCombinations
   For intField = 0 To objRecordset.Fields.Count - 1
       intTotalLengthToCutFromStockmm = intTotalLengthToCutFromStockmm + objRecordset(intField)
       strCombination = strCombination & "[" & objRecordset(intField) & "] "
   Next
   
   ' Check if the combination is within the allowable MaximumWastePercent if so then output it.
   intWaste = intStockPieceLengthmm - intTotalLengthToCutFromStockmm
   
   If intWaste < 0 Then
      ' The stock length has been exceeded
   Else
      ' Work out the waste percentage.
      vntWastePercent = Round((intWaste / intStockPieceLengthmm) * 100, 3)


      If vntWastePercent <= MaximumWastePercent Then
         ' The combination is within the acceptable wastage limit so output it.
         lngBestCombinationCount = lngBestCombinationCount + 1
         wsBestCombinations.Cells(lngRow, "A") = strCombination
         wsBestCombinations.Cells(lngRow, "B") = intTotalLengthToCutFromStockmm
         wsBestCombinations.Cells(lngRow, "C") = vntWastePercent
         
         lngRow = lngRow + 1
      End If
   End If
   
   ' Set the variables ready for the next record.
   intTotalLengthToCutFromStockmm = 0
   strCombination = ""


   objRecordset.MoveNext
   
   lngRecordCount = lngRecordCount + 1
Loop


objRecordset.Close
objConnection.Close


Set objRecordset = Nothing
Set objConnection = Nothing


' Remove the duplicate combinations.
wsBestCombinations.Columns("A:A").Select
wsBestCombinations.Range("A1:C" & LastRow(wsBestCombinations, 1)).RemoveDuplicates Columns:=1, Header:=xlYes


' Format wsBestCombinations.
wsBestCombinations.Select
wsBestCombinations.Rows("1:1").Select
Selection.Font.Bold = True
wsBestCombinations.Cells.Select
Selection.Columns.AutoFit


' Sort wsBestCombinations.
wsBestCombinations.Columns("C:C").Select
wsBestCombinations.Sort.SortFields.Clear
wsBestCombinations.Sort.SortFields.Add2 Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsBestCombinations.Sort
    .SetRange Range("A2:C" & Trim(Str(LastRow(wsBestCombinations, 1))))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


' Delete the SQL Cross Join Query tables for each item to cut from the stock piece.
For intTable = intNoOfItemsToCutFromStockPiece To 1 Step -1
    objOrderWorksheet.Columns(intTable + 1).Delete Shift:=xlToLeft
Next


MsgBox "Finished analysing the best combinations." & vbCrLf & _
       Trim(Str(lngRecordCount)) & " possible combinations were analysed." & vbCrLf & _
       "Resulting in " & Trim(Str(lngBestCombinationCount)) & " possible best combinations.", _
       vbOKOnly + vbInformation, "Best Combinations Analysis Complete"


Exit Function


ErrorBestCombinations:
'Debug.Print "Error Number : "; Err.Number
'Debug.Print Err.Description
Resume Next


End Function


Public Function ColumnLetter(intColumnNumber As Integer) As String


If intColumnNumber > 26 Then
   ' 1st character: Subtract 1 to map the characters to 0-25,
   ' but you don't have to remap back to 1-26
   ' after the 'Int' operation since columns
   ' 1-26 have no prefix letter
   ' 2nd character: Subtract 1 to map the characters to 0-25,
   ' but then must remap back to 1-26 after
   ' the 'Mod' operation by adding 1 back in
   ' (included in the '65')
    ColumnLetter = Chr(Int((intColumnNumber - 1) / 26) + 64) & _
    Chr(((intColumnNumber - 1) Mod 26) + 65)
Else
   ' Columns A-Z
   ColumnLetter = Chr(intColumnNumber + 64)
End If


End Function


Public Function LastRow(objWorkSheetFindLastRow As Worksheet, intColFindLastRow As Integer) As Long


' Ensure that the column being passed is populated for all rows for the correct last row to be returned.
With objWorkSheetFindLastRow
     LastRow = .Cells(.Rows.Count, intColFindLastRow).End(xlUp).Row
End With


End Function


Public Sub PopulateOrderCombinations(objOrderWorksheet As Worksheet, objWorksheetToPopulate As Worksheet)


Dim lngBestCombinationRow As Long
Dim lngRow As Long
Dim lngPopulateRow As Long
Dim strJobNumber As String


' Delete existing data.
objWorksheetToPopulate.Select
objWorksheetToPopulate.Cells.Select
Selection.Delete Shift:=xlUp
' Create headings.
objWorksheetToPopulate.Cells(1, "A") = "Order Combinations"


lngBestCombinationRow = objOrderWorksheet.Cells(2, "C")
lngPopulateRow = 2


' Loop through the Best Combination Row column.
For lngRow = 2 To LastRow(objOrderWorksheet, 3)
    If objOrderWorksheet.Cells(lngRow, "C") = lngBestCombinationRow Then
       strJobNumber = strJobNumber & objOrderWorksheet.Cells(lngRow, "A") & ", "
    Else
       objWorksheetToPopulate.Cells(lngPopulateRow, "A") = wsBestCombinations.Cells(lngBestCombinationRow, "A") & " Job #s " & strJobNumber
       strJobNumber = objOrderWorksheet.Cells(lngRow, "A") & ", "
       lngPopulateRow = lngPopulateRow + 1
    End If
    
    lngBestCombinationRow = objOrderWorksheet.Cells(lngRow, "C")
Next


objWorksheetToPopulate.Cells(lngPopulateRow, "A") = wsBestCombinations.Cells(lngBestCombinationRow, "A") & " Job #s " & strJobNumber


' Format objWorksheetToPopulate.
objWorksheetToPopulate.Select
objWorksheetToPopulate.Rows("1:1").Select
Selection.Font.Bold = True
objWorksheetToPopulate.Cells.Select
Selection.Columns.AutoFit


End Sub


Sub TestCombinations()


' 6096mm (20ft)
' 12192mm (40ft)
' 18288mm (60ft)


Application.ScreenUpdating = False
' Change parameters to suit the required analysis.
BestCombinations wsOrder, 12192, 4, "40ft (12192mm)"
AddBestCombinationRowToOrder wsOrder
PopulateOrderCombinations wsOrder, wsOrderCombinations
Application.ScreenUpdating = True


End Sub

Display More

Tom Rowe · Jun 11th 2019

Hi,

Don't know what's causing the error for you as the sorting works fine for me. Did you delete the X's from the Order column before you ran it which could cause problems ? If you can post a debug of the code where it is failing I will have a look to see if I can replicate it or add some error handling to get more information. Also what version of Excel are you using which can cause problems if different from mine which is Office 365 Excel 2016.

It should be relatively simple to add the job Id as that would be done last when you check what order length matches what combination. I was also thinking it would be better to make the subroutine AddBestCombinationRowToOrder that does that more generic so you can pass a worksheet object to it specifying what Worksheet you want the order on rather than being limited to wsOrder.

Regards,

Tom

Tom Rowe · Jun 11th 2019

Hi,

To accomplish exactly what you are after is quite difficult as you have a lot of variables to deal with.

As it was a typical June rainy day yesterday here in the UK and I like a challenge thought I would have a stab at trying to do this.

My solution uses a SQL cross join query. A cross join (or cartesian join) is used when you wish to create combination of every row from two or more tables. All row combinations' are included in the result. The tables used for the cross join are just a copy of the order data. You have to specify the number of lengths you want to cut from a stock pieces i.e. in my code below it is 4 so 4 tables are create and the SQL cross join query is...

SQL

SELECT * FROM [B:B], [C:C], [D:D], [E:E]

The solution is not 100% perfect as some of the order lengths don't fit a generated combination. But I guess you could always try running it with different parameters or work out the remaining lengths yourself. You don't want to do yourself completely out of your job... :smile:

I have attached an example 2016 Workbook 'Best Combinations.xlsm' with the working code.

Regards,

Tom Rowe...

VBA Code Follows...

Code

Option Explicit


Public Sub AddBestCombinationRowToOrder()


Dim blnCombinationMatched As Boolean
Dim intOrder As Integer
Dim lngRow As Long
Dim lngRowUndo As Long
Dim strAddComment As String
Dim strFind As String
Dim rngFoundCell As Range
Dim vntArrayBestCombination As Variant
Dim vntBestCombination As Variant


' Create header.
wsOrder.Cells(1, "B") = "Best Combination Row "


' Loop through the best combinations.
For lngRow = 2 To LastRow(wsBestCombinations, 1)
    vntBestCombination = Replace(wsBestCombinations.Cells(lngRow, "A"), "[", "")
    vntArrayBestCombination = Split(vntBestCombination, "]")
    ' Match the combinations with the order lengths.
    For intOrder = LBound(vntArrayBestCombination) To UBound(vntArrayBestCombination)
        With wsOrder
             If Trim(vntArrayBestCombination(intOrder)) <> "" Then
                Set rngFoundCell = .Columns("A").Find(What:=Trim(vntArrayBestCombination(intOrder)), After:=.Cells(1, 1), LookIn:=xlFormulas, _
                                   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            
                If Not rngFoundCell Is Nothing Then
                   ' Tag and highlight the order.
                   rngFoundCell.Value = rngFoundCell.Value & " X"
                   rngFoundCell.Interior.Color = vbYellow
                   wsOrder.Cells(rngFoundCell.Row, "B") = lngRow
                   strAddComment = "Combination: " & vbCrLf & wsBestCombinations.Cells(lngRow, "A") & vbCrLf & "Wastage: " & vbCrLf & _
                                    wsBestCombinations.Cells(lngRow, "C") & " %"
                   wsOrder.Cells(rngFoundCell.Row, "B").AddComment (strAddComment)
                Else
                   blnCombinationMatched = False
                End If
             End If
       End With
    Next
    
    If blnCombinationMatched = False Then
       ' Undo the Tag and highlight for the order.
       For lngRowUndo = 2 To LastRow(wsOrder, 1)
           If wsOrder.Cells(lngRowUndo, "B") = lngRow Then
              wsOrder.Cells(lngRowUndo, "A") = Replace(wsOrder.Cells(lngRowUndo, "A"), " X", "")
              wsOrder.Cells(lngRowUndo, "A").Interior.Color = xlNone
              wsOrder.Cells(lngRowUndo, "B") = ""
              wsOrder.Cells(lngRowUndo, "B").ClearComments
            End If
       Next
        
       blnCombinationMatched = True
    End If
Next


' Format wsOrder.
wsOrder.Select
wsOrder.Rows("1:1").Select
Selection.Font.Bold = True
wsOrder.Cells.Select
Selection.Columns.AutoFit


' Sort wsOrder.
wsOrder.Columns("B:B").Select
wsOrder.Sort.SortFields.Clear
wsOrder.Sort.SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsOrder.Sort
    .SetRange Range("A2:B" & Trim(Str(LastRow(wsBestCombinations, 1))))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


End Sub


Function BestCombinations(intStockPieceLengthmm As Integer, intNoOfItemsToCutFromStockPiece As Integer, strStock As String)


' Change if you require less wastage.
Const MaximumWastePercent = 15
Dim intField As Integer
Dim intTotalLengthToCutFromStockmm As Integer
Dim intTable As Integer
Dim intWaste As Integer
Dim lngBestCombinationCount As Long
Dim lngRecordCount As Long
Dim lngRow As Long
Dim vntWastePercent As Variant
Dim objConnection As Object
Dim objRecordset As Object
Dim strCombination As String
Dim strFieldValue As String
Dim strSQL As String


' Delete existing data.
wsBestCombinations.Select
wsBestCombinations.Cells.Select
Selection.Delete Shift:=xlUp
' Create headings.
wsBestCombinations.Cells(1, "A") = "Combination"
wsBestCombinations.Cells(1, "B") = "Combination Length"
wsBestCombinations.Cells(1, "C") = "Stock " & strStock & " Wastage %"


' Create the SQL Tables for the cross join query.
wsOrder.Select
wsOrder.Columns("A").Select
Selection.Copy
For intTable = 1 To intNoOfItemsToCutFromStockPiece
    wsOrder.Columns(intTable + 1).Select
    wsOrder.Paste
Next


Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")


With objConnection
     .Provider = "Microsoft.ACE.OLEDB.12.0"
     .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
     .Open
End With


' Build the SQL cross join query.
' A cross join (or cartesian join) is used when you wish to create combination of every row from two or more tables.  All row combinations
' are included in the result.
For intTable = 1 To intNoOfItemsToCutFromStockPiece
    strSQL = strSQL & "[" & ColumnLetter(intTable + 1) & ":" & ColumnLetter(intTable + 1) & "]"
    If intTable <> intNoOfItemsToCutFromStockPiece Then strSQL = strSQL & ", "
Next


strSQL = "SELECT * FROM " & strSQL


' Run the query.
objRecordset.Open strSQL, objConnection


lngRow = 2


' Loop through the record set
Do Until objRecordset.EOF
   On Error GoTo ErrorBestCombinations
   For intField = 0 To objRecordset.Fields.Count - 1
       intTotalLengthToCutFromStockmm = intTotalLengthToCutFromStockmm + objRecordset(intField)
       strCombination = strCombination & "[" & objRecordset(intField) & "] "
   Next
  
   ' Check if the combination is within the allowable MaximumWastePercent if so then output it.
   intWaste = intStockPieceLengthmm - intTotalLengthToCutFromStockmm
  
   If intWaste < 0 Then
      ' The stock length has been exceeded
   Else
      ' Work out the waste percentage.
      vntWastePercent = Round((intWaste / intStockPieceLengthmm) * 100, 3)


      If vntWastePercent <= MaximumWastePercent Then
         ' The combination is within the acceptable wastage limit so output it.
         lngBestCombinationCount = lngBestCombinationCount + 1
         wsBestCombinations.Cells(lngRow, "A") = strCombination
         wsBestCombinations.Cells(lngRow, "B") = intTotalLengthToCutFromStockmm
         wsBestCombinations.Cells(lngRow, "C") = vntWastePercent
        
         lngRow = lngRow + 1
      End If
   End If
  
   ' Set the variables ready for the next record.
   intTotalLengthToCutFromStockmm = 0
   strCombination = ""


   objRecordset.MoveNext
  
   lngRecordCount = lngRecordCount + 1
Loop


objRecordset.Close
objConnection.Close


Set objRecordset = Nothing
Set objConnection = Nothing


' Remove the duplicate combinations.
wsBestCombinations.Columns("A:A").Select
wsBestCombinations.Range("A1:C" & LastRow(wsBestCombinations, 1)).RemoveDuplicates Columns:=1, Header:=xlYes


' Format wsBestCombinations.
wsBestCombinations.Select
wsBestCombinations.Rows("1:1").Select
Selection.Font.Bold = True
wsBestCombinations.Cells.Select
Selection.Columns.AutoFit


' Sort wsBestCombinations.
wsBestCombinations.Columns("C:C").Select
wsBestCombinations.Sort.SortFields.Clear
wsBestCombinations.Sort.SortFields.Add2 Key:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsBestCombinations.Sort
    .SetRange Range("A2:C" & Trim(Str(LastRow(wsBestCombinations, 1))))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


' Delete the SQL Cross Join Query tables for each item to cut from the stock piece.
For intTable = intNoOfItemsToCutFromStockPiece To 1 Step -1
    wsOrder.Columns(intTable + 1).Delete Shift:=xlToLeft
Next


MsgBox "Finished analysing the best combinations." & vbCrLf & _
       Trim(Str(lngRecordCount)) & " possible combinations were analysed." & vbCrLf & _
       "Resulting in " & Trim(Str(lngBestCombinationCount)) & " possible best combinations.", _
       vbOKOnly + vbInformation, "Best Combinations Analysis Complete"


Exit Function


ErrorBestCombinations:
'Debug.Print "Error Number : "; Err.Number
'Debug.Print Err.Description
Resume Next


End Function


Public Function ColumnLetter(intColumnNumber As Integer) As String


If intColumnNumber > 26 Then
   ' 1st character: Subtract 1 to map the characters to 0-25,
   ' but you don't have to remap back to 1-26
   ' after the 'Int' operation since columns
   ' 1-26 have no prefix letter
   ' 2nd character: Subtract 1 to map the characters to 0-25,
   ' but then must remap back to 1-26 after
   ' the 'Mod' operation by adding 1 back in
   ' (included in the '65')
    ColumnLetter = Chr(Int((intColumnNumber - 1) / 26) + 64) & _
    Chr(((intColumnNumber - 1) Mod 26) + 65)
Else
   ' Columns A-Z
   ColumnLetter = Chr(intColumnNumber + 64)
End If


End Function


Public Function LastRow(objWorkSheetFindLastRow As Worksheet, intColFindLastRow As Integer) As Long


' Ensure that the column being passed is populated for all rows for the correct last row to be returned.
With objWorkSheetFindLastRow
     LastRow = .Cells(.Rows.Count, intColFindLastRow).End(xlUp).Row
End With


End Function


Sub TestCombinations()


' 6096mm (20ft)
' 12192mm (40ft)
' 18288mm (60ft)


Application.ScreenUpdating = False
' Change parameters to suit the required analysis.
BestCombinations 12192, 4, "40ft (12192mm)"
AddBestCombinationRowToOrder
Application.ScreenUpdating = True


End Sub

Display More

Tom Rowe · Jun 6th 2019

Hi,

Try something along the following lines...

Code

Option Explicit


Sub CheckColumnHeadings()


CheckColumnHeadingIsPresent "Col1", 1
CheckColumnHeadingIsPresent "Col2", 2
CheckColumnHeadingIsPresent "Col3", 3
CheckColumnHeadingIsPresent "Col4", 4
CheckColumnHeadingIsPresent "Col5", 5
CheckColumnHeadingIsPresent "Col6", 6
CheckColumnHeadingIsPresent "Col7", 7
CheckColumnHeadingIsPresent "Col8", 8
CheckColumnHeadingIsPresent "Col9", 9
CheckColumnHeadingIsPresent "Col10", 10


MsgBox "Column headings checked.", _
       vbOKOnly + vbInformation, _
       "Column Headings Checked"


End Sub


Sub CheckColumnHeadingIsPresent(strColumnHeading As String, intPosition As Integer)


If wsData.Cells(1, intPosition) <> strColumnHeading Then
   ' The column heading is missing so insert it at intPosition.
   wsData.Columns(intPosition).Select
   Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   wsData.Cells(1, intPosition) = strColumnHeading
End If


End Sub

Display More

Note: The code assumes that the column headings are in row 1.

I have attached an example workbook 'Check and Insert Missing Columns.xlsm' with the above code.

Regards,

Tom Rowe...

Tom Rowe · Jun 4th 2019

Hi,

Off the top of my head I am wondering if you are setting DisableX to False in your UserForms Close Workbook Subroutine ?

Regards,

Tom Rowe.

Tom Rowe · May 25th 2019

Hi,

Perhaps just try looping through all the columns, something along the following lines...

Code

Sub ExportData()
On Error Resume Next
    
    Dim FilePath As String
    Dim LastRow As Long
    Dim CellData As String
    Dim WS2 As Worksheet
    Dim i As Long
    Dim intColumn as Integer
    Dim RowsNos As Long
    
    Set WS2 = Workbooks("Book1.xlsm").Sheets("Names")
    FilePath = "C:\Data" & "\" & "Data.txt"
    RowsNos = Workbooks("Book1.xlsm").Sheets("Names").Range("F" & Rows.Count).End(xlUp).Row
    Open FilePath For Output As #1
    For i = 2 To RowsNos
        For intColumn = 6 to 43
            CellData = CellData & "," & WS2.Cells(i, intColumn).Value
        Next
        Print #1, CellData
    Next i
    Close #1
End Sub

Display More

Note: The above is off the top of my head so not tested.

Regards,

Tom Rowe...

Tom Rowe · May 25th 2019

Hi,

The way to accomplish this to have a For Next Loop to loop through the ActiveSheet shapes. With a

Code

Select Case objWindowDoorType.Fill.ForeColor]

with Case that checks for the RGB fill ForeColor i.e.

Code

Case RGB(255, 255, 0) ' Yellow - Glazing Bead - Replacable

From the Case you then call a subroutine to count the glazing beads according to the Window and Door Type.

Code

CountGlazingBeads objWindowDoorType.TextFrame2.TextRange.Text

Note : Because you are reliant on checking the shape's RGB fill ForeColor it's important that you use the actual colour to fill the shape.

The following code should accomplish what you are after...

Code

Option Explicit


Private objWindowDoorType As Shape
Private intDamagedWindowsDoors As Integer
Private intBlue As Integer
Private intFrameDamage As Integer
Private intGlazingBeads As Integer
Private intGlazingBeadReplacable As Integer
Private intLightBlue As Integer
Private intOrange As Integer
Private intWindowScreenOnly As Integer


Public Sub CountWindowsAndDoors()


' Reset the counters.
intDamagedWindowsDoors = 0
intBlue = 0
intFrameDamage = 0
intGlazingBeads = 0
intGlazingBeadReplacable = 0
intLightBlue = 0
intOrange = 0
intWindowScreenOnly = 0


For Each objWindowDoorType In ActiveSheet.shapes
    Select Case objWindowDoorType.Fill.ForeColor
          Case RGB(255, 0, 0) ' Red - Frame Damage
              intDamagedWindowsDoors = intDamagedWindowsDoors + 1
              intFrameDamage = intFrameDamage + 1
          Case RGB(255, 192, 0) ' Orange
              intDamagedWindowsDoors = intDamagedWindowsDoors + 1
              intOrange = intOrange + 1
          Case RGB(0, 176, 240) ' Light Blue
              intDamagedWindowsDoors = intDamagedWindowsDoors + 1
              intLightBlue = intLightBlue + 1
           Case RGB(0, 112, 192) ' Dark Blue
              intDamagedWindowsDoors = intDamagedWindowsDoors + 1
              intBlue = intBlue + 1
          Case RGB(255, 255, 0) ' Yellow - Glazing Bead - Replacable
              intDamagedWindowsDoors = intDamagedWindowsDoors + 1
              intGlazingBeadReplacable = intGlazingBeadReplacable + 1
              CountGlazingBeads objWindowDoorType.TextFrame2.TextRange.Text
          Case RGB(146, 208, 80) ' Light Green - Window Screen Only
              intDamagedWindowsDoors = intDamagedWindowsDoors + 1
              intWindowScreenOnly = intWindowScreenOnly + 1
    End Select
Next


' Populate the totals in the Buildings Worksheet.
ActiveSheet.Range("T126") = intGlazingBeads
ActiveSheet.Range("T127") = intWindowScreenOnly


MsgBox "Finished counting Windows and Doors..." & vbCrLf & vbCrLf & _
       "Damaged Windows and Doors =" & Str(intDamagedWindowsDoors) & vbCrLf & _
       "Frame Damage =" & Str(intFrameDamage) & vbCrLf & _
       "Orange =" & Str(intOrange) & vbCrLf & _
       "Light Blue =" & Str(intLightBlue) & vbCrLf & _
       "Blue = " & Str(intBlue) & vbCrLf & _
       "Glazing Beading - Replaceable = " & Str(intGlazingBeadReplacable) & vbCrLf & _
       "Window Screen Only =" & Str(intWindowScreenOnly) & vbCrLf & _
       "Total Glazing Bead This Building =" & Str(intGlazingBeads), _
       vbOKOnly + vbInformation, _
       "Counted Windows and Doors"


End Sub


Private Sub CountGlazingBeads(strType As String)


' Note : Change intGlazingBeads = intGlazingBeads  + n(Glazing Beads) in accordance
'        with the number of Glazing Beads for the Window and Door type.


Select Case Trim(UCase(strType))
      Case "A"
          ' Type A - 6x5 Mulled SHxSH
          intGlazingBeads = intGlazingBeads + 9
      Case "B"
          ' Type B - 1'6"x1'6" Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "C"
          ' Type C - 2x6 SH
          intGlazingBeads = intGlazingBeads + 1
      Case "D"
          ' Type D - 4x6 Picture
          intGlazingBeads = intGlazingBeads + 6
      Case "E"
          ' Type E - 2x5 Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "F"
          ' Type F - 3x5 Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "G"
          ' Type G - 2x6'3 Mulled SHxP
          intGlazingBeads = intGlazingBeads + 1
      Case "H"
          ' Type H - 4x6'3 Mulled PxP
          intGlazingBeads = intGlazingBeads + 4
      Case "I"
          ' Type I - 5x7'8" Mulled SGDxP
          intGlazingBeads = intGlazingBeads + 10
      Case "J"
          ' Type J - 5x5 Slider
          intGlazingBeads = intGlazingBeads + 1
      Case "K"
          ' Type K - 2x4 Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "L"
          ' Type L - 2'6"x5 SH
          intGlazingBeads = intGlazingBeads + 1
      Case "M"
          ' Type M - 6x3 Mulled PxP
          intGlazingBeads = intGlazingBeads + 1
      Case "N"
          ' Type N - 6x4 Slider
          intGlazingBeads = intGlazingBeads + 1
      Case "O"
          ' Type O - 6x7 Mulled SHxP
          intGlazingBeads = intGlazingBeads + 1
      Case "P"
          ' Type P - 2'6"x4 Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "Q"
          ' Type Q - 4x4 Slider
          intGlazingBeads = intGlazingBeads + 1
      Case "R"
          ' Type R - 4x4 Mulled PxP
          intGlazingBeads = intGlazingBeads + 1
      Case "S"
          ' Type S - 6x5 Slider
          intGlazingBeads = intGlazingBeads + 1
      Case "T"
          ' Type T - 6x3'3" Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "U"
          ' Type U - 6x2 Picture
          intGlazingBeads = intGlazingBeads + 6
      Case "V"
          ' Type V - 2x3 Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "W"
          'Type W - 6x5 Picture
          intGlazingBeads = intGlazingBeads + 1
      Case "X"
          'Type X - 5x6 Mulled SHxSH
          intGlazingBeads = intGlazingBeads + 1
      Case "Y"
          ' Type Y - 3x6'4" Mulled SHxP
          intGlazingBeads = intGlazingBeads + 1
      Case "Z"
          ' Type Z - 4x6'4" Mulled PxP
          intGlazingBeads = intGlazingBeads + 1
      Case "AA"
          ' Type AA - 3x4 SH
          intGlazingBeads = intGlazingBeads + 1
      Case "BB"
          ' Type BB - 3x6 SH
          intGlazingBeads = intGlazingBeads + 1
      Case "CC"
          ' Type CC - 2x4 SH
          intGlazingBeads = intGlazingBeads + 1
End Select


End Sub

Display More

Note: You didn't say how many glazing beads there are for each Window and Door type so I set arbitrary values in subroutine CountGlazingBeads. So these need to be set to their correct values.

The beauty of this approach is that you can count any other required items for the Windows and Doors i.e. Handles, Hinges, Locks etc by simple creating and calling a subroutine for it from the ActiveSheet shapes For Next Loop.

I have attached an Excel 2016 32Bit workbook 'Object Sample Sheet.xlsm' with working code for you.

Regards,

Tom Rowe...

Tom Rowe · May 25th 2019

Hi,

Firstly the structure of your workbook worksheet doesn't lend itself to doing this type of thing easily so I have altered it.

The following code should accomplish what you are after...

Code

Option Explicit


' Worksheet Handing.
Public lngRow730291 As Long
Public lngLastRowTest As Long


Public Function LastRow(objWorkSheetFindLastRow As Worksheet, intColFindLastRow As Integer) As Long


' Ensure that the column being passed is populated for all rows for the correct last row to be returned.
With objWorkSheetFindLastRow
     LastRow = .Cells(.Rows.Count, intColFindLastRow).End(xlUp).Row
End With


End Function


Public Sub MoveRow()


' Move the row from ws730291 starting at Row 2 to the Next Free Row in wsTest.


If wsTest.chkDeleteSample = True Then
   ' Delete the moved row mode.
   On Error Resume Next
   If ws730291.Range("A2") = "" Then
      ' No more Rows to move.
      MsgBox "There are no further valid rows to move from worksheet " & ws730291.Name & ".", _
      vbOKOnly + vbInformation, _
      "No Further Rows to Move"
      
      Exit Sub
   End If


   ' Select and copy the Row to be moved.
   ws730291.Range("A2:V2").Copy


   ' Paste the row to the LastRow + 1 in wsTest.
   lngLastRowTest = LastRow(wsTest, 1)
   wsTest.Range("A" & lngLastRowTest + 1 & ":V" & lngLastRowTest + 1).PasteSpecial
  
   ws730291.Rows(2).Delete
Else
   ' Don't delete the moved row mode.
   lngRow730291 = lngRow730291 + 1


   ' Ignore the first row.
   If lngRow730291 = 1 Then lngRow730291 = 2


   ' Check if the last row in ws730291 has been reached.
   If lngRow730291 >= LastRow(ws730291, 1) + 1 Then
      ' No more Rows to move.
      MsgBox "There are no further rows to move from worksheet " & ws730291.Name & ".", _
             vbOKOnly + vbInformation, _
             "No Further Rows to Move"
  
      Exit Sub
   End If


   ' Select and copy the Row to be moved.
   ws730291.Range("A" & lngRow730291 & ":V" & lngRow730291).Copy


   ' Paste the row to the LastRow + 1 in wsTest.
   lngLastRowTest = LastRow(wsTest, 1)
   wsTest.Range("A" & lngLastRowTest + 1 & ":V" & lngLastRowTest + 1).PasteSpecial
End If


End Sub


Public Sub Reset730291RowCounter()


lngRow730291 = 0


End Sub

Display More

Note : There are two modes ' Delete the moved row mode' or '' Don't delete the moved row mode' depending on the setting of wsTest.chkDeleteSample.

I have attached an Excel 2016 32Bit Workbook 'Trends.xlsm' with the working code.

Regards,

Tom Rowe...

Tom Rowe · May 25th 2019

Hi,

Perhaps try checking first if the file is already open. If it's not then run your code, see...

Macro code to check whether a file is already open

https://support.microsoft.com/en-gb/help/291295/macro-code-to-check-whether-a-file-is-already-open

Regards,

Tom Rowe...

Tom Rowe · May 6th 2019

Hi,

You seem to be over complicating things by using Visual Studio. An Excel Ribbon is essentially just an XML file I build them for my projects and Add_ins in NotePad ++ i.e.

OnAction is the name of the Macro you want to run from the ribbon.

From here rename your excel file to a .zip extension and copy the xml ribbon file to the root folder.

Then create an xml .rels file to point at xml ribbon file i.e. Target="UK_postcode_search_and_geocoding_ribbon.xml.

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">
<Relationship Id="rId3" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/>
<Relationship Id="rId2" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/>
<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="xl/workbook.xml"/>
<Relationship Id="customUIRelID" Target="UK_postcode_search_and_geocoding_ribbon.xml" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"/>
</Relationships>

which you copy to the _rels folder.

If you do a Google Search for creating excel ribbons there are plenty of examples on how to do this.

Also there is a very good Add-in for the Microsoft Office built in Ribbon Icons available at...

https://www.spreadsheet1.com/how-to-...-in-excel.html

You can also have your own custom icons but that gets a little bit more complex as you have to set up a CustomUI folder for them within the zip file and have references to these in a custom .rels file.

Finally if you post a copy of your Workbook you will be more likely to get exact help on how to do this.

Regards,

Tom Rowe...

Tom Rowe · May 6th 2019

Hi,

I suggest defining the Lookup Value as a Variant type i.e.

Code

Dim lotnum As Variant

That way it is not dependent on the cell format in the look up array. i.e. suppose the cell format in the lookup array is Text and the Lookup Value is an Integer type you will get an error.

Also define the Return Variable Lot_List as either a Double or Long Type.

Regards,

Tom Rowe...

Tom Rowe · Apr 20th 2019

Hi,

Try the following...

Code

Option Explicit


' Worksheet Handing.
Public lngRow As Long


Public Function LastRow(objWorkSheetFindLastRow As Worksheet, intColFindLastRow As Integer) As Long


' Ensure that the column being passed is populated for all rows for the correct last row to be returned
With objWorkSheetFindLastRow
     LastRow = .Cells(.Rows.Count, intColFindLastRow).End(xlUp).Row
End With


End Function


Sub CopyToNewSheet()


' Delete the existing data
wsNewSheet.Select
Cells.Select
Selection.ClearContents


wsNewSheet.Cells(1, "A") = "Copied Data"
wsNewSheet.Cells(1, "A").Font.Bold = True


' Loop through the rows and copy to a new sheet
For lngRow = 2 To LastRow(wsOldSheet, 1)
    wsNewSheet.Cells(lngRow, "A") = wsOldSheet.Cells(lngRow, "C") & " " & wsOldSheet.Cells(lngRow, "A") & " " & _
                                    wsOldSheet.Cells(lngRow, "B")
Next


Columns("A:A").Select
Selection.Columns.AutoFit


MsgBox "Copy to new sheet complete.", _
       vbOKOnly + vbInformation, _
       "Copy to New Sheet Complete"


End Sub

Display More

I have attached an Excel 2016 Workbook 'copy_to_another_sheet.xlsm' with the working code...

Regards,

Tom Rowe...

Tom Rowe · Mar 19th 2019

Hi,

Found this on a Google search possibly your Network Folder where the add-in is stored may not be a Trusted Location...

https://www.excelcampus.com/vba/add-in-ribbon-disappears/

Regards,

Tom Rowe...

Tom Rowe · Mar 18th 2019

Hi,

Possibly the Add-in is not saved to the user's local Addins folder...

C:\Users\Thomas\Appdata\Roaming\Microsoft\Addins\

Regards,

Tom Rowe..

Posts by Tom Rowe

Error 400 Caused By Custom Ribbon ?

Error 400 Caused By Custom Ribbon ?

Error 400 Caused By Custom Ribbon ?

Export data from excel workbook to google sheet

Text Box in UserForm - Carriage Returns in MultiLine?

prevent entering a duplicate serial number

Find best combination of numbers to meet a goal

Find best combination of numbers to meet a goal

Find best combination of numbers to meet a goal

To check if column header exists and if not then add column with that header

Excel sheet not closing after Quiting application

Macro to export range from different worksheet (not active sheet) to txt file

Count Objects With Values/Formatting

Copy one row at a time

Automatically acknowledge 'File currently in use' message box when saving workbook

Convert VBA Excel to MS Visual Studio addin

application.match "Run-time error '13' Type mismatch"

Copy a cell n times at the end of the column

Disappearing Add-in

Disappearing Add-in