I have a loop which run about 300,000 times at every iteration I stored:
time_elps = stwt.Elapsed.TotalMilliseconds
read.Add(time_elps, OFV_best)
Finally I just want to take the values of read (a dictionary of course) to draw a graph on excel.
I tried to export this data to excel:
oxl = CreateObject("Excel.application")
oxl.Visible = True
owb = oxl.Workbooks.Add
osheet = owb.ActiveSheet
For i = 0 To 100
osheet.Cells(i + 1, 1).Value = read.Item(read.Keys.ElementAt(i))
osheet.Cells(i + 1, 2).value = read.Keys.ElementAt(i)
Next
and to a text file:
objStreamWriter = New StreamWriter("C:\Users\Dr. Mohamed ElWakil\Desktop\data.txt")
For i = 0 To read.Count - 1
objStreamWriter.WriteLine(CStr(read.Item(read.Keys.ElementAt(i)) & "," & (read.Keys.ElementAt(i))))
Next
objStreamWriter.Close()
In two cases it takes too too much time, it's longer than the time of running the code itself.
What do you suggest to get my data easily and fast?
Writing each value seperately to Excel is just really slow, have a go with this:
Dim arr2D(100, 1) As String
For i = 0 To 100
arr2D(i, 0) = read.Item(read.Keys.ElementAt(i))
arr2D(i, 1) = read.Keys.ElementAt(i)
Next
Dim oExcel As Object = CreateObject("Excel.Application")
Dim oWorkbook As Object = oExcel.Workbooks.Add
Dim oWorksheet As Object = oWorkbook.Worksheets(1)
Dim vRange As Object = oWorksheet.Range("A1")
vRange = vRange.Resize(UBound(arr2D, 1) + 1, UBound(arr2D, 2) + 1)
vRange.Formula = arr2D
vRange.Columns.autofit()
oExcel.Visible = True
every time I creat a new txt file with name "data" tailed with time.hour and time.minute
as #NicoSchertler, using for each var in read to get var.value and var.key
this is the fastest way
Dim file As System.IO.StreamWriter
Dim path As String
path = "C:\Users\Dr. Mohamed ElWakil\Desktop\data" & Now.Hour & Now.Minute & ".txt"
file = My.Computer.FileSystem.OpenTextFileWriter(path, True)
For Each var In read
file.WriteLine(var.Key & "," & var.Value)
Next
file.Close()
Related
I am trying to compare files by objects to find dublicate. I have 2900 files in folder and i need to check them all. In other words I have to run compare methods 2900*2900 times and every time when comparing two file I need to open and close 1 of those. If there is a way to work with Corel files not to open them? or is it posible to get metadata\metadata.xml from Corel VBA files to check and compare some parametrs from it such as Objects(shapes) count?
I am in despered...
I am using this logic system
Private Sub CommandButton1_Click()
Dim Folder As String
MousePointer = fmMousePointerHourGlass
Folder = BrowseForFolderDlg("o:\", "Select Source Folder", GetWindowHandle("ThunderDFrame", Me.Caption))
tb_inputFolder.text = Folder
End Sub
Private Sub CommandButton2_Click()
Dim fso As Object
Dim objFolder As Object
Dim objFileList As Object
Dim vFile, vFile1 As Variant
Dim inputFolder As String, outputFolder As String
inputFolder = tb_inputFolder.text 'input folder
If (inputFolder = "") Then
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(inputFolder)
Set objFileList = objFolder.Files
Dim currentFile As String
Dim dunFiles() As String
Dim arrLength As Integer
ReDim Preserve dunFiles(1)
arrLength = 1
dunFiles(0) = ""
For Each vFile In objFileList
Dim doc As Document, doc1 As Document, buf As String
Dim fName As String
fName = (Left(vFile.name, Len(vFile.name) - 4))
buf = Right(vFile.path, 3)
If (buf = "cdr" And findArrayElement(dunFiles, arrLength, vFile.name) = -1) Then
Set doc = OpenDocument(vFile.path) 'document opend
dunFiles(arrLength - 1) = vFile.name
ReDim Preserve dunFiles((arrLength + 1))
arrLength = arrLength + 1
For Each vFile1 In objFileList
buf = Right(vFile1.path, 3)
If (vFile1.name = currentFile Or findArrayElement(dunFiles, arrLength, vFile1.name) <> -1 Or buf <> "cdr") Then
GoTo nextElement
End If
'Set doc1 = OpenDocument(vFile1.path) 'document opend
Dim res As Variant
res = writeFile(doc.FileName + " VS " + vFile1.name + " " + Str(Now), doc.FilePath + "compare.log")
If (compareDocs(doc, vFile1.path)) Then
dunFiles(arrLength - 1) = fName + "_" + vFile1.name
ReDim Preserve dunFiles((arrLength + 1))
arrLength = arrLength + 1
Dim name As String
name = vFile.ParentFolder.path + "\" + fName + "_" + vFile1.name
Name vFile1.path As name
res = writeFile(vFile.ParentFolder.path + "\" + fName + " the same as " + name, doc.FilePath + "rename.log")
End If
'doc1.Close
nextElement:
Next vFile1
doc.Close
End If
' doc.Close 'close document
Next vFile
lb_info.Caption = "Finished! Press exit"
End Sub
Private Function findArrayElement(inputArray() As String, inputLen As Integer, element As String)
Dim e As String
Dim i As Integer
findArrayElement = -1
For i = 0 To inputLen - 1
If (inputArray(i) = element) Then
findArrayElement = i
Exit Function
End If
Next i
End Function
Private Function compareDocs(doc As Document, path2 As String)
Dim doc1 As Document
Dim e1 As Shape, e2 As Shape, elements() As String
Dim sameShapesCount As Integer
sameShapesCount = 0
ReDim elements(1) As String
elements(0) = ""
Set doc1 = OpenDocument(path2) 'document opend
compareDocs = False
lb_info.Caption = "Comapre " + doc.FullFileName + " with " + path2
For Each e1 In doc.SelectableShapes
e1.UngroupAll
Next e1
For Each e2 In doc1.SelectableShapes
e2.UngroupAll
Next e2
If (doc.SelectableShapes.Count <> doc1.SelectableShapes.Count) Then
doc1.Close
Exit Function
End If
For Each e1 In doc.SelectableShapes
'If (findArrayElement(elements, (UBound(elements) + 1), Str(e1.StaticID)) = -1) Then
'ReDim Preserve elements(UBound(elements) + 1) As String
'elements(UBound(elements)) = e1.StaticID
For Each e2 In doc1.SelectableShapes
If (findArrayElement(elements, (UBound(elements) + 1), "2_" + Str(e2.StaticID)) = -1) Then
If (e1.CompareTo(e2, cdrCompareShapeType, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareFillType, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareOutline, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareOutlineColor, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareOutlineWidth, cdrCompareEquals)) Then
'If (e1.CompareTo(e2, cdrCompareShapeHeight, cdrCompareEquals)) Then
If (e1.CompareTo(e2, cdrCompareFil, cdrCompareEquals)) Then
'If (e1.CompareTo(e2, cdrCompareShapeWidth, cdrCompareEquals)) Then
ReDim Preserve elements(UBound(elements) + 1) As String
elements(UBound(elements)) = "2_" + Str(e2.StaticID)
sameShapesCount = sameShapesCount + 1
GoTo nextElement1
'End If
End If
'End If
End If
End If
End If
End If
End If
End If
Next e2
'End If
nextElement1:
Next e1
If (doc.SelectableShapes.Count = sameShapesCount) Then
compareDocs = True
End If
doc1.Close
End Function
Private Function writeFile(text As String, path As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
If Not Dir(path, vbDirectory) = vbNullString Then
Set oFile = fso.OpenTextFile(path, 8)
Else
Set oFile = fso.CreateTextFile(path, 0)
End If
oFile.WriteLine text
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Function
The main problem is that the "open process" can last up to few minutes and to check 2k corel fiels I need a YEAR
In a first pass, open each file once.
Go over the data you care about -- object count or whatever -- that must be equal.
From this data, build a hash -- a pseudo-random value that combines information from each of them.
Build a table that maps from the hash to a set of draw files that match the hash.
Now you only have to compare files which have a the same hash value, not every pair of files. A well designed hash and data to feed it should reduce your collision rate to nearly zero.
This should speed up your program by a factor of 1000 to 3000 or so.
To ensure that the hash/collision works well, your first pass should just hash and print out the lists of collisions.
Sort the list by filesize. Only compare files that are similar in size. You can use dir to generate a sorted list by size.
You only need to open each file once. Hash each file (maybe an alphabetically list of object names). Store and sort and dupes are the same objects.
You can use excel if it's a one off, or a recordset if you need to do it in code.
I am new to coding VBA. Was wondering if you all could help me? I have a CSV file which is structured as the following:
- First 22 rows cover the specfic header data(this all loads in one column in excel)
- column headers for table are in Row 23
- the data is actually located from row 24 onward.
What the code needs to do is insert this data in new table with the right column titles. Also while inserting it needs to input the file name and header data in the first few columns of the table.
So far I have imported the entire CSV into an array I believe:
See what I have so far:
Sub readCSV()
Dim fs As Object
Dim fso As New FileSystemObject
Dim tsIn As Object
Dim sFileIn, filename As String
Dim aryFile, aryHeader, aryBody As Variant
sFileIn = "C:\doc\test.csv"
Set filename = fso.GetFileName(sFileIn)
Set fs = CreateObject("Scripting.FileSystemObject")
Set tsIn = fs.OpenTextFile(sFileIn, 1)
sTmp = tsIn.ReadAll
aryFile = Split(sTmp, vbCrLf)
For i = 1 To 22
aryHeader(1, i) = aryFile(i)
Next i
For i = 23 To UBound(aryFile)
aryBody(i) = Split(aryFile(i), ",")
DoCmd.RunSQL "INSERT INTO MAINS VALUES (filename,aryHeader(1),aryBody(i))"
Next i
End Sub
is this correct? Can anyone see of i am taking the right approach
UPDATE - recoded this a bit
Use DoCmd.TransferText instead of rolling out your own code:
http://msdn.microsoft.com/en-us/library/office/ff835958%28v=office.15%29.aspx
In your Import Specification, you can set the starting row.
See Skip first three lines of CSV file (using DoCmd?) in MS Access for more information!
Edit: The import specification can be changed to rename the fields etc. See http://www.access-programmers.com/creating-an-import-specification-in-access-2003.aspx (the Import wizard exists in Access 2007 as well) and the Advanced dialog specifically.
I was a bit irked by the use of multiple arrays in your code (which is super confusing, to me, anyway, because you are looking at counters everywhere) so I thought I would post an alternative for you. If you can do it your way, more power to you, but if you run into problems, you can try this. Code below is much more verbose, but may save you time in the future if you hand it off or even have to come back to it yourself and have no idea what is going on (lol):
Sub ReadCSV()
On Error GoTo ErrorHandler
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim fso As Scripting.FileSystemObject
Dim tst As Scripting.TextStream
Dim strFileName As String
Dim intCurrentLine As Integer
Dim strCurrentLine As String
Dim intHeaderRows As Integer
Dim strHeader As String
Dim strHeaderDelimInField As String
'Consider these your 'constants', so you don't come back to this code in a month
'and wonder what the random numbers mean.
intHeaderRows = 22 'Number of header rows in CSV.
strHeaderDelimInField = "~" 'The character(s) you want to separate each
'header line, in field.
strFileName = "C:\IrregularCSV.csv"
intCurrentLine = 1 'Keep track of which line in the file we are currently on.
'Next two lines get a reference to your table; will add data via DAO and not SQL,
'to avoid messy dynamic SQL.
Set db = CurrentDb()
Set rst = db.OpenRecordset("Mains", dbOpenDynaset)
Set fso = New Scripting.FileSystemObject
Set tst = fso.OpenTextFile(strFileName, ForReading)
'Instead of storing data in arrays, let's go through the file line by line
'and do the work we need to do.
With tst
Do Until .AtEndOfStream
strCurrentLine = .ReadLine
If intCurrentLine <= intHeaderRows Then
strHeader = strHeader & strHeaderDelimInField & strCurrentLine
Else
'Add the records via DAO here.
rst.AddNew
'In DAO, rst.Fields("FieldName") are the columns in your table.
rst.Fields("FileName") = strFileName
'Remove leading delimiter with Right.
rst.Fields("HeaderInfo") = Right(strHeader, Len(strHeader) - 1)
'Note that Split always returns a zero-based array
'and is unaffected by the Option Base statement.
'The way below is less efficient than storing
'the return of Split, but also less confusing, imo.
rst.Fields("Field1") = Split(strCurrentLine, ",")(0)
rst.Fields("Field2") = Split(strCurrentLine, ",")(1)
rst.Fields("Field3") = Split(strCurrentLine, ",")(2)
rst.Update
End If
intCurrentLine = intCurrentLine + 1
Loop
End With
tst.Close
rst.Close
ExitMe:
Set tst = Nothing
Set fso = Nothing
Set rst = Nothing
Set db = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ": " & Err.Description
GoTo ExitMe
End Sub
To be honest, I think there are a lot of gotchas to the way you are going about it. Not saying it won't work, because I think it can, but this method is more robust. An unexpected single quote won't ruin your work and using a data object to do the inserts is not prone (well, less, at least) to SQL injection issues. And I've done it with no persisted arrays. Anyway, some food for thought. Good luck.
this is what i ended up:
Sub ReadCSV2()
Dim fs As Object
Dim filename As String
Dim tsIn As Object
Dim sFileIn As String
Dim aryHeader, aryBody As Variant
Dim Text As String
Dim sqlcre As String
Dim sqlsta As String
sFileIn = "C:\test\test.csv"
filename = GetFilenameFromPath(sFileIn) 'function to get the file name
Set fs = CreateObject("Scripting.FileSystemObject")
Set tsIn = fs.OpenTextFile(sFileIn, 1)
For i = 1 To 23
Tmps = tsIn.ReadLine
Next i
aryHeader = Split(Tmps, ",")
On Error Resume Next
DoCmd.RunSQL "DROP TABLE tempdata"
On Error GoTo 0
sqlcre = "CREATE TABLE tempdata ([Filename] Text,"
For k = LBound(aryHeader) To UBound(aryHeader)
sqlcre = sqlcre & "[" & aryHeader(k) & " " & k + 1 & "] Text,"
Next k
k = k - 1
sqlcre = Left(sqlcre, Len(sqlcre) - 13) & ")"
'Debug.Print k
'Debug.Print sqlcre
DoCmd.RunSQL sqlcre
DoCmd.SetWarnings False
While Not tsIn.AtEndOfStream
Tmps = tsIn.ReadLine
aryBody = Split(Tmps, ",")
sqlsta = "INSERT INTO tempdata VALUES ('" & filename & "','"
For M = LBound(aryBody) To UBound(aryBody)
sqlsta = sqlsta & Replace(aryBody(M), "'", "`") & "', '"
Next M
M = M - 1
Debug.Print M
If M < k Then
Text = ""
For i = 1 To (k - M)
Text = Text & "', '"
Next i
sqlsta = sqlsta & Text
End If
sqlsta = Left(sqlsta, Len(sqlsta) - 7) & ")"
'Debug.Print sqlsta
'Debug.Print k
DoCmd.RunSQL sqlsta
Wend
DoCmd.SetWarnings True
End Sub
I would like to loop through an Excel worksheet and to store the values based on a unique ID in a text file.
I am having trouble with the loop and I have done research on it with no luck and my current nested loop continually overflows. Instead of updating the corresponding cell when the control variable is modified, it continues to store the initial Index value for all 32767 iterations.
Please can someone explain why this is happening, and provide a way of correcting it?.
Sub SortLetr_Code()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Value of cell for example B1 starts out as X
Dim x As Integer
Dim y As Integer
x = 2
y = 2
'Cell References
Dim rwCounter As Range
Dim rwCorresponding As Range
Dim rwIndexValue As Range
Dim rwIndexEnd As Range
Dim rwIndexStore As Range
'Variables for files that will be created
Dim FilePath As String
Dim Filename As String
Dim Filetype As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
Filetype = ".dat"
'Use Cell method for Loop
rwIndex = Cells(x, "B").Value
Set rwCounter = Range("B" & x)
'Use Range method for string manipulation
Set rwCorresponding = Range("A" & x)
Set rwIndexValue = Range("B" & y)
Set rwIndexStore = Range("B" & x)
Set rwIndexEnd = Range("B:B").End(xlUp)
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
For Each rwIndexStore In rwIndexEnd.Cells
'Get Substring of cell value in BX for the file name
Do Until IsEmpty(rwCounter)
Filename = Mid$(rwIndexValue, 7, 5)
Set FileWrite = FileCreate.CreateTextFile(FilePath + Filename + Filetype)
'Create the file
FileWrite.Write (rwCorresponding & vbCrLf)
Do
'Add values to the textfile
x = x + 1
FileWrite.Write (rwCorresponding & vbCrLf)
Loop While rwCounter.Value Like rwIndexValue.Value
'Close this file
FileWrite.Close
y = x
Loop
Next rwIndexStore
End Sub
I don't see a place you are setting rwCounter inside the loop.
It looks like it would stay on range("B2") and x would just continue to increase until it hits an error, either at the limit of integer or long.
add Set rwCounter = Range("B" & x) somewhere inside your loop to increment it
This is the solution.
Sub GURMAIL_File()
'sort columns for Letr_Code files
Dim lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort key1:=Range("B2"), order1:=1
Application.ScreenUpdating = True
'Variables that store cell number
Dim Corresponding As Integer
Dim Index As Integer
Dim Counter As Integer
Corresponding = 2
Index = 2
Counter = 2
'Cell References
Dim rwIndexValue As Range
'Variables for files that will be created
Dim l_objFso As Object
Dim FilePath As String
Dim Total As String
Dim Filename As String
Dim Filetype As String
Dim FolderName As String
'Variables defined
FilePath = "C:\Users\Home\Desktop\SURLOAD\"
'Name of the folder to be created
FolderName = Mid$(ActiveWorkbook.Name, 9, 8) & "\"
'Folder path
Total = FilePath & FolderName
'File Extension
Filetype = ".dat"
'Object that creates the folder
Set l_objFso = CreateObject("Scripting.FileSystemObject")
'Objects for creating the text files
Dim FileCreate As Object
Set FileCreate = CreateObject("Scripting.FileSystemObject")
'Object for updating the file during the loop
Dim FileWrite As Object
'Get Substring of letter code in order to name the file. End this loop once ID field is null.
Do While Len(Range("A" & Corresponding)) > 0
'Create the directory if it does not exist
If Not l_objFso.FolderExists(Total) Then
l_objFso.CreateFolder (Total)
End If
'Refence to cell containing a letter code
Set rwIndexValue = Range("B" & Index)
'Substring of that letter code
Filename = Mid$(rwIndexValue, 7, 5)
'Create the file using the substring and store it in the proper location
Set FileWrite = FileCreate.CreateTextFile(Total + Filename + Filetype, True)
'For each letter code, find the corresponding values. End the loop once the last value for the letter code is stored.
Do While Range("B" & Index) Like Range("B" & Counter)
'Add each line to the text file.
FileWrite.WriteLine (Range("A" & Corresponding))
'Incrementer variables that allow you to exit the loop
'if you have reached the last value of the current letter code.
Corresponding = Corresponding + 1
Counter = Counter + 1
Loop
'Close the file you were writing to
FileWrite.Close
'Make sure that Index value is updated to the next letter code
Index = Counter
'In case Index value needs updating (safeguard to make sure that the new letter code is stored to index value).
Set rwIndexValue = Range("B" & Index)
Loop
End Sub
I have a series of freeform shapes copied from a third party application.
These freeform shapes are made of open paths, which cannot be "combined" in PowerPoint (only freeforms made with closed paths can be combined).
The following macro goes through every shape selected, and if it is a freeform, it will create a copy with a closed path and then delete the original shape.
Sub close_poly()
Dim myshp As Shape
Dim mycol As String
Dim mynode As ShapeNode
Dim myxvals As Variant
Dim myyvals As Variant
Dim myxcol As String
Dim myycol As String
Dim myffb As FreeformBuilder
Dim mynewshp As Shape
Dim myname As String
For Each myshp In ActiveWindow.Selection.ShapeRange
With myshp
If .Type = msoFreeform Then
'################ set all line segments to straight
'(makes things easier in my specific case but will not work in many)
nodecount = 1
While nodecount <= .Nodes.Count
.Nodes.SetSegmentType nodecount, msoSegmentLine
nodecount = nodecount + 1
Wend
'############## collect coordinates
myxcol = ""
myycol = ""
For Each mynode In myshp.Nodes
myxcol = myxcol & mynode.Points(1, 1) & ","
myycol = myycol & mynode.Points(1, 2) & ","
Next
myxcol = Left(myxcol, Len(myxcol) - 1)
myycol = Left(myycol, Len(myycol) - 1)
myxvals = Split(myxcol, ",")
myyvals = Split(myycol, ",")
'##############create new freeform
Set myffb = ActiveWindow.View.Slide.Shapes.BuildFreeform(msoEditingAuto, myxvals(0), myyvals(0))
For i = 1 To UBound(myxvals)
myffb.AddNodes msoSegmentLine, msoEditingAuto, myxvals(i), myyvals(i)
Next i
myffb.AddNodes msoSegmentLine, msoEditingAuto, myxvals(0), myyvals(0)
Set mynewshp = myffb.ConvertToShape
myshp.PickUp
mynewshp.Apply
myname = myshp.Name
myshp.Delete
mynewshp.Name = myname
End If
End With
Next myshp
End Sub
Question: is there a simpler way to mimic the program's "close path" function in VBA?
Cheers
I'm trying to write a macro that will create a table of contents, listing the name of each of the worksheets currently selected by the user, together with the number of the page on which it starts when printed. I've taken the code from this page and adapted it a little as below.
However, when the new worksheet ("Contents") is created, that becomes the active, selected sheet, such that I can no longer use ActiveWindow.SelectedSheets to refer back to the collection of worksheets selected by the user. So I would like to store that information before creating the new sheet. How can I do this?
I have tried assigning it to a variable of type Worksheets as you can see, but this generates an error message. (I also tried Collection but to no avail.)
Sub CreateTableOfContents()
' Determine if there is already a Table of Contents
' Assume it is there, and if it is not, it will raise an error
' if the Err system variable is > 0, you know the sheet is not there
Dim WST As Worksheet
Dim SelSheets As Worksheets
Set SelSheets = ActiveWindow.SelectedSheets
On Error Resume Next
Set WST = Worksheets("Contents")
If Not Err = 0 Then
' The Table of contents doesn't exist. Add it
Set WST = Worksheets.Add(Before:=Worksheets("blankMagnitude"))
WST.Name = "Contents"
End If
On Error GoTo 0
' Set up the table of contents page
WST.[A2] = "Table of Contents"
With WST.[A6]
.CurrentRegion.Clear
.Value = "Subject"
End With
WST.[B6] = "Page(s)"
WST.Range("A1:B1").ColumnWidth = Array(36, 12)
TOCRow = 7
PageCount = 0
' Do a print preview on all sheets so Excel calcs page breaks
' The user must manually close the PrintPreview window
Msg = "Excel needs to do a print preview to calculate the number of pages." & vbCrLf & "Please dismiss the print preview by clicking close."
MsgBox Msg
SelSheets.PrintPreview
' Loop through each sheet, collecting TOC information
For Each S In SelSheets
If S.Visible = -1 Then
S.Select
ThisName = ActiveSheet.Name
HPages = ActiveSheet.HPageBreaks.Count + 1
VPages = ActiveSheet.VPageBreaks.Count + 1
ThisPages = HPages * VPages
' Enter info about this sheet on TOC
WST.Select
Range("A" & TOCRow).Value = ThisName
Range("B" & TOCRow).NumberFormat = "#"
If ThisPages = 1 Then
Range("B" & TOCRow).Value = PageCount + 1 & " "
Else
Range("B" & TOCRow).Value = PageCount + 1 & " " ' & - " & PageCount + ThisPages
End If
PageCount = PageCount + ThisPages
TOCRow = TOCRow + 1
End If
Next S
End Sub
I just amended your code. Is this what you are trying? Honestly all you had to do was
Change Dim SelSheets As Worksheets to Dim SelSheets and your original code would have worked :)
Option Explicit
Sub CreateTableOfContents()
Dim WST As Worksheet, S As Worksheet
Dim SelSheets
Dim msg As String
Dim TOCRow As Long, PageCount As Long, ThisPages As Long
Dim HPages As Long, VPages As Long
Set SelSheets = ActiveWindow.SelectedSheets
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Contents").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set WST = Worksheets.Add(Before:=Worksheets("blankMagnitude"))
With WST
.Name = "Contents"
.[A2] = "Table of Contents"
.[A6] = "Subject"
.[B6] = "Page(s)"
.Range("A1:B1").ColumnWidth = Array(36, 12)
End With
TOCRow = 7: PageCount = 0
msg = "Excel needs to do a print preview to calculate the number of pages." & vbCrLf & "Please dismiss the print preview by clicking close."
MsgBox msg
SelSheets.PrintPreview
For Each S In SelSheets
With S
HPages = .HPageBreaks.Count + 1
VPages = .VPageBreaks.Count + 1
ThisPages = HPages * VPages
WST.Range("A" & TOCRow).Value = .Name
WST.Range("B" & TOCRow).NumberFormat = "#"
If ThisPages = 1 Then
WST.Range("B" & TOCRow).Value = PageCount + 1 & " "
Else
WST.Range("B" & TOCRow).Value = PageCount + 1 & " " ' & - " & PageCount + ThisPages
End If
PageCount = PageCount + ThisPages
TOCRow = TOCRow + 1
End With
Next S
End Sub
EDIT: One important thing. It's always good to use OPTION EXPLICIT :)
You could store references to each sheet;
function getSheetsSnapshot() as Worksheet()
dim shts() As Worksheet, i As long
redim shts(ActiveWindow.SelectedSheets.Count - 1)
for i = 0 to ActiveWindow.SelectedSheets.Count - 1
set shts(i) = ActiveWindow.SelectedSheets(i + 1)
next
getSheetsSnapshot = shts
end function
fetch & store them:
dim oldsel() as Worksheet: oldsel = getSheetsSnapshot()
do your stuff then refer back to the original selected sheets;
for i = 0 to ubound(oldsel)
msgbox oldsel(i).name
next
Dim wks as Worksheet, strName as String
For each wks in SelSheets
strName = strName & wks.Name & ","
Next
strName = Left(strName, Len(strName) -1)
Dim arrWks() as String
arrWks = Split(strName,",")
End Sub
Your will have all the selected sheets, by name, in an arrWks, which you can then process through. You could also add each sheet name to a collection as well in the loop making it smoother.
It's best to stay away from ActiveSheet as much as possible. In this way you can loop through array with a counter and process
So:
Dim intCnt as Ingeter
For intCnt = Lbound(arrWks) to UBound(arrWks)
Worksheets(arrWks(intCnt)).Activate
.... rest of code ....
Next
replaces
For Each S In SelSheets