Solved

Need help with a sorting algorithm within Excel's sheets using an array.

Posted on 2015-01-02
8
221 Views
Last Modified: 2015-01-02
I have an array called sSheet(100) that stores each Excel's Sheet Name as it should be sorted and the total number is in variable iSheet.   Based on the what I have my Excel workbook should have the following Sheets sorted according to that array's listing from 0 to iSheet.

How do I rearrange the following to allow for the sort to exist?

'put code here to sort sheets in the order as in access..
  For j = 0 To iSheet
      
    For Each xlSheetReview In xlBook.Worksheets
      If xlSheetReview.Name = sSheet(j) Then
        
        'not sure how to handle the move code at this point.
        'this is what I found online
        '        
      End If
    Next
  Next

Open in new window

0
Comment
Question by:stephenlecomptejr
  • 5
  • 3
8 Comments
 
LVL 119

Expert Comment

by:Rey Obrero
ID: 40528692
try

'put code here to sort sheets in the order as in access..
  For j = 0 To iSheet
     
    For Each xlSheetReview In xlBook.Worksheets
      If xlSheetReview.Name = sSheet(j) Then
        
            xlSheetReview.Name.Move Before:=Worksheets(j+1)
        exit for      
      End If
    Next
  Next
0
 
LVL 119

Expert Comment

by:Rey Obrero
ID: 40528705
try

 'put code here to sort sheets in the order as in access..
   For j = 0 To iSheet
       
     For Each xlSheetReview In xlBook.Worksheets
       If xlSheetReview.Name = sSheet(j) Then
         
             xlSheetReview.Name.Move Before:=xlBook.Worksheets(j+1)
         exit for      
       End If
     Next
   Next
0
 
LVL 1

Author Comment

by:stephenlecomptejr
ID: 40528720
I get an object required - run-time error '424' on this line item:

xlSheetReview.Name.Move Before:=xlBook.Worksheets(j + 1)

I tried also...

xlSheetReview.Name.Move Before:=xlApp.Worksheets(j + 1)

Please forgive the stupid question also:
But I know at some point you have to check if xlSheetReview.Name = sSheet(j) but does that mean you have to move it then each time you find it.  In many cases, it will not have to move at all.
0
 
LVL 119

Expert Comment

by:Rey Obrero
ID: 40528723
post the whole code.
0
Comprehensive Backup Solutions for Microsoft

Acronis protects the complete Microsoft technology stack: Windows Server, Windows PC, laptop and Surface data; Microsoft business applications; Microsoft Hyper-V; Azure VMs; Microsoft Windows Server 2016; Microsoft Exchange 2016 and SQL Server 2016.

 
LVL 1

Author Comment

by:stephenlecomptejr
ID: 40528725
Ok.   You asked for it.

Your section begins at:
 'CODE FOR EXPERTS-EXCHANGE STARTS HERE...
  '@@@@@@@@@@@@@

Public Sub ExportValuesToExcel(sExcel As String)

  Dim sSQL As String
  Dim rs As DAO.Recordset
  Dim sProjectName As String
  Dim sProjectNumber As String

  Dim xlApp As Object
  Dim xlBook As Object
  Dim xlSheet  As Object
  Dim xlSheetReview As Object
  Dim xlSheetNameCheck As Object
  
  Dim cell As Object
  Dim Range As Object
  
  Dim sFormula As String
  Dim sSheet(100) As String
  Dim sDiscipline(100) As String
  Dim sPhase(100) As String
  Dim sRange, sCell As String
  Dim sRange2 As String
  Dim sRangeNew As String
  Dim sRangeNew2 As String
  Dim sNewSheetName As String
  Dim bContinue As Boolean
  Dim bFound As Boolean
  
  Dim CopyThis As Object
  
  Dim i, j, k, l, m, n, o, p As Long
  Dim iSheet, iDiscipline, iPhase As Integer
  
  
  txtImporting = "Setting sheets, phases and discipline values..."
  DoEvents
  
  
  '===================================================================
  '1st step - make sure all sheets are to be shown based on selection...
  'store as an array...
  
  sSQL = "SELECT Projects_Sheets.SheetID, Projects_Sheets.SheetSort, Projects_Sheets.SheetNames"
  sSQL = sSQL & " FROM Projects_Sheets"
  sSQL = sSQL & " ORDER BY Projects_Sheets.SheetSort"
  Set rs = CurrentDb.OpenRecordset(sSQL)
  i = 0
  Do Until rs.EOF
    i = i + 1
    sSheet(i) = Nz(rs.Fields(2), "")
    Debug.Print sSheet(i)
    rs.MoveNext
  Loop
  rs.Close
  Set rs = Nothing
  iSheet = i
  

  '===================================================================
  '2nd step - store project name, number in variables.
  
  sSQL = "SELECT Projects.ProjNumber, Projects.ProjName"
  sSQL = sSQL & " FROM Projects"

  Set rs = CurrentDb.OpenRecordset(sSQL)
  If Not rs.EOF Then
    sProjectNumber = Nz(rs.Fields(0), "")
    sProjectName = Nz(rs.Fields(1), "")
  End If
  rs.Close
  Set rs = Nothing
  
  
  '===================================================================
  '3rd step - set array to how many disciplines there are...
  
  
  sSQL = "SELECT Projects_Disciplines.DisciplineID, Projects_Disciplines.DisciplineSort, Projects_Disciplines.DisciplineNames"
  sSQL = sSQL & " FROM Projects_Disciplines"
  sSQL = sSQL & " ORDER BY Projects_Disciplines.DisciplineSort;"

  Set rs = CurrentDb.OpenRecordset(sSQL)
  i = 0
  Do Until rs.EOF
    i = i + 1
    sDiscipline(i) = Nz(rs.Fields(2), "")
    Debug.Print sDiscipline(i)
    rs.MoveNext
  Loop
  rs.Close
  Set rs = Nothing
  iDiscipline = i
  
  
  '===================================================================
  '4th step - set arry to how many phases there are....
  sSQL = "SELECT Projects_Phases.PhaseID, Projects_Phases.PhaseSort, Projects_Phases.PhaseName"
  sSQL = sSQL & " FROM Projects_Phases"
  sSQL = sSQL & " ORDER BY Projects_Phases.PhaseSort;"

  Set rs = CurrentDb.OpenRecordset(sSQL)
  i = 0
  Do Until rs.EOF
    i = i + 1
    sPhase(i) = Nz(rs.Fields(2), "")
    Debug.Print sPhase(i)
    rs.MoveNext
  Loop
  rs.Close
  Set rs = Nothing
  iPhase = i
  
  txtImporting = "Opening Excel..."
  DoEvents
  'find sheet number in Excel that has...
  '
  'Home Page - list disciplines, phases vertically, deliverables
  'Contracted Fee
  'Scope Managemnet
  'Activity Items
  Set xlApp = CreateObject("Excel.Application")
  'Opens Excel TEMPlate always from the C:\ to reduce traffic
  Set xlBook = xlApp.Workbooks.Open(sExcel)
  
  'deleting sheets that are not selected in the data...
  xlApp.DisplayAlerts = False
  For Each xlSheetReview In xlBook.Worksheets
  
      bFound = False
      Debug.Print xlSheetReview.Name
      
      For j = 0 To iSheet
      
        If xlSheetReview.Name = sSheet(j) Then
          
          bFound = True
          
        End If
      Next
      
      If bFound = False Then
        sNewSheetName = xlSheetReview.Name
        xlApp.Sheets(sNewSheetName).Delete
      End If
  Next
  xlApp.DisplayAlerts = True


  For Each xlSheetReview In xlBook.Worksheets
      '
      Debug.Print xlSheetReview.Name
      
      For j = 0 To iSheet
      
        If xlSheetReview.Name = sSheet(j) Then
        
          Set xlSheet = xlBook.Worksheets(j)
          xlSheet.Activate
          xlSheet.Application.Visible = False
          
'            xlSheet.Application.ScreenUpdating = False
'            xlSheet.Application.DisplayStatusBar = False
'            xlSheet.Application.Calculation = -4135
          
          Select Case sSheet(j)
          
       
            Case "Home Page"
              'list in order down...
              xlSheet.Range("B1") = sProjectName
              xlSheet.Range("B2") = sProjectNumber
              
              k = 8
              For l = 1 To iDiscipline
                k = k + 1
                sRange = "A" & k
                sRange = Replace(sRange, " ", "")
                xlSheet.Range(sRange) = sDiscipline(l)
                
              Next l
              k = k + 2
              sRange = "A" & k
              sRange = Replace(sRange, " ", "")
              
              'm stores row where Phases is...
              m = k
              xlSheet.Range(sRange) = "Phases"
              xlSheet.Range(sRange).Font.Bold = True
              
              
              For l = 1 To iPhase
                k = k + 1
                sRange = "A" & k
                sRange = Replace(sRange, " ", "")
                xlSheet.Range(sRange) = sPhase(l)
                
              Next l
              
              'now display disciplines...
              'take the location at m
              'and fill out the disciplines as a header...
              'problem is how to identify next letter
              'as header range...
              'interesting problem...
              n = 1
              For l = 1 To iDiscipline
                n = n + 1
                xlSheet.Cells(m, n) = sDiscipline(l)
                
              Next l
              
              k = k + 2
              sRange = "A" & k
              sRange = Replace(sRange, " ", "")
              
              m = k
              xlSheet.Range(sRange) = "Deliverables"
              xlSheet.Range(sRange).Font.Bold = True
              
              n = 1
              For l = 1 To iDiscipline
                n = n + 1
                xlSheet.Cells(m, n) = sDiscipline(l)
                
              Next l
              
              xlSheet.Columns("A:A").EntireColumn.AutoFit
              
            
            
            Case "Contracted Fee"
            
              k = 2
              For l = 1 To iPhase
                k = k + 3
                sRange = "A" & k
                sRange = Replace(sRange, " ", "")
                xlSheet.Range(sRange) = sPhase(l)
                
              Next l
              m = k  'last row... 39 is the limit in the template...
              
              'find DISCIPLINE TOTAL
              'and then delete rows in between....
              
              'now display disciplines...
              k = 1
              For l = 1 To iDiscipline
                k = k + 1
                xlSheet.Cells(4, k) = sDiscipline(l)
                
              Next l
              
              'k = k + 1
              ' last column   whereas 16 is the limit in the template..
              If n < 8 Then n = 8
            
              sRange = Col_Letter(n)
              sRange2 = Col_Letter(16)
              sRangeNew = sRange & ":" & sRange2
              xlSheet.Columns(sRangeNew).Delete
              
              
         
              'delete rows until complete.
              m = m + 3
              
              sRange = m
              sRange2 = "43"
              sRangeNew = sRange & ":" & sRange2
              sRangeNew = Replace(sRangeNew, " ", "")
              xlSheet.Rows(sRangeNew).Delete
              
            
            Case "Scope Management"
              'make copies per discipline
              
              
              
              k = 0
              For l = 1 To iDiscipline
                k = k + 5
                sRange = "B" & k
                sRange = Replace(sRange, " ", "")
                xlSheet.Range(sRange) = sDiscipline(l)
                
              Next l
              
              'do this
              'last row...
              m = k + 5
              
              sRange = m
              sRange2 = "79"
              
              sRangeNew = sRange & ":" & sRange2
              sRangeNew = Replace(sRangeNew, " ", "")
              xlSheet.Rows(sRangeNew).Delete
            
            Case "Time Management"
              'first loop through each discipline and make a copy of each one and name it...

              For l = iDiscipline To 1 Step -1
              
                  sNewSheetName = "Time Management-" & sDiscipline(l)
                  If Len(sNewSheetName) > 31 Then
                    sNewSheetName = Left(sNewSheetName, 31)
                  End If
              
                  Set CopyThis = xlApp.Sheets("Time Management")
                  CopyThis.Copy After:=xlApp.Sheets("Time Management")
                  Set CopyThis = Nothing
                  Set CopyThis = xlApp.Sheets("Time Management (2)")
                  
                  CopyThis.Name = sNewSheetName
                  
                  k = 6
                  For m = 1 To iPhase
                    k = k + 1
                    sRange = "B" & k
                    sRange = Replace(sRange, " ", "")
                    
                    CopyThis.Range(sRange) = sPhase(m)
                    k = k + 2
                  Next
                  
                  m = k + 1
              
                  sRange = m
                  sRange2 = "43"
                  sRangeNew = sRange & ":" & sRange2
                  sRangeNew = Replace(sRangeNew, " ", "")
                  CopyThis.Rows(sRangeNew).Delete
                  
                  Set CopyThis = Nothing
                


              Next l
              
              'xlApp.Sheets("Time Management").Delete
              
              
              
            Case "Cost Management"
            
              For l = iDiscipline To 1 Step -1
              
                  sNewSheetName = "Cost Management-" & sDiscipline(l)
                  If Len(sNewSheetName) > 31 Then
                    sNewSheetName = Left(sNewSheetName, 31)
                  End If
                  
                

                  Set CopyThis = xlApp.Sheets("Cost Management")
                  CopyThis.Copy After:=xlApp.Sheets("Cost Management")
                  Set CopyThis = Nothing
                  Set CopyThis = xlApp.Sheets("Cost Management (2)")
                  
                  
                  CopyThis.Name = sNewSheetName
                  
                  'copy rows....
                  o = 9
                  
                  k = 8
                  For m = 1 To iPhase
                    k = k + 1
                    
                    If m > 1 Then
                  
                      o = o + 14
                      p = o + 13
                      sRange = "9"
                      sRange2 = "22"
                      sRangeNew = sRange & ":" & sRange2
                      sRangeNew = Replace(sRangeNew, " ", "")
                      sRangeNew2 = o & ":" & p
                      sRangeNew2 = Replace(sRangeNew2, " ", "")
                      CopyThis.Rows(sRangeNew).Copy Destination:=xlApp.Worksheets(sNewSheetName).Range(sRangeNew2)
                  
                    End If
                    
                    sRange = "A" & k
                    sRange = Replace(sRange, " ", "")
                    
                    CopyThis.Range(sRange) = sPhase(m)
                    k = k + 13
                  Next
                  
                  Set CopyThis = Nothing
                

                

              Next l
              'xlApp.Sheets("Cost Management").Delete
              
            
            Case "Activity List"
            
              n = 0
              For l = 1 To iDiscipline
                n = n + 1
                xlSheet.Cells(3, n) = sDiscipline(l)
              Next l
              m = l
              
              k = 3
              For l = 1 To iPhase
                
                k = k + 1
                
                For n = 1 To m
                  xlSheet.Cells(k, n) = sPhase(l)
                Next n
                k = k + 13
                
              Next l
              
              
              'Stop
              m = k + 1
              sRange = m
              sRange2 = "185"
              sRangeNew = sRange & ":" & sRange2
              sRangeNew = Replace(sRangeNew, " ", "")
              xlSheet.Rows(sRangeNew).Delete
              
              sRange = Col_Letter(iDiscipline + 1)
              sRange2 = Col_Letter(16)
              sRangeNew = sRange & ":" & sRange2
              xlSheet.Columns(sRangeNew).Delete
              
              
            
            Case Else
              'do that
          
          
          End Select
          
          'xlSheet.Application.ScreenUpdating = True
          'xlSheet.Application.DisplayStatusBar = True
          'xlSheet.Application.Calculation = -4105
          
          Set xlSheet = Nothing
          Exit For
        
        End If
      
      
      Next j
  Next


  
  xlApp.DisplayAlerts = False
  For Each xlSheetReview In xlBook.Worksheets
    If xlSheetReview.Name = "Cost Management" Then
      xlApp.Sheets("Cost Management").Delete
      Exit For
    End If
  Next

  For Each xlSheetReview In xlBook.Worksheets
    If xlSheetReview.Name = "Time Management" Then
      xlApp.Sheets("Time Management").Delete
      Exit For
    End If
  Next
  xlApp.DisplayAlerts = True
  
  'CODE FOR EXPERTS-EXCHANGE STARTS HERE...
  '@@@@@@@@@@@@@
  
  For j = 0 To iSheet

      For Each xlSheetReview In xlBook.Worksheets
        If xlSheetReview.Name = sSheet(j) Then
              xlSheetReview.Name.Move Before:=xlBook.Worksheets(j + 1)
          Exit For
        End If
      Next

  Next
  
  
  Set xlSheet = xlBook.Worksheets(1)
  xlSheet.Activate
  Set xlSheet = Nothing
  
  xlBook.Save
  xlBook.Close
  Set xlBook = Nothing
  Set xlApp = Nothing
 
 
End Sub

Open in new window

0
 
LVL 119

Accepted Solution

by:
Rey Obrero earned 500 total points
ID: 40528738
try

xlBook.Worksheets(xlSheetReview.Name).Move Before:=xlBook.Worksheets(j + 1)
0
 
LVL 119

Expert Comment

by:Rey Obrero
ID: 40528740
if that does not work, try

xlApp.Worksheets(xlSheetReview.Name).Move Before:=xlApp.Worksheets(j + 1)
0
 
LVL 1

Author Comment

by:stephenlecomptejr
ID: 40528769
That worked.  Thank you.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …

932 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now