Need help with a sorting algorithm within Excel's sheets using an array.
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?
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
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(
exit for
End If
Next
Next
'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(
exit for
End If
Next
Next
ASKER
I get an object required - run-time error '424' on this line item:
xlSheetReview.Name.Move Before:=xlBook.Worksheets(
I tried also...
xlSheetReview.Name.Move Before:=xlApp.Worksheets(j
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.
xlSheetReview.Name.Move Before:=xlBook.Worksheets(
I tried also...
xlSheetReview.Name.Move Before:=xlApp.Worksheets(j
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.
post the whole code.
ASKER
Ok. You asked for it.
Your section begins at:
'CODE FOR EXPERTS-EXCHANGE STARTS HERE...
'@@@@@@@@@@@@@
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 SubASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
if that does not work, try
xlApp.Worksheets(xlSheetRe
xlApp.Worksheets(xlSheetRe
ASKER
That worked. Thank you.
'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