Free Microsoft Excel 2013 Quick Reference

Rename excel sheet in vba code Results

Can you help? I'm new to VBA (but learning fast), I've got some code that does a SaveAs (*.prn), but this also renames the active sheet. Can you help with some code to rename it back to the original? (as static name is need due to other coding).
Thanks, Russ

Hi! Is it possible to access in VBA a "readable" version of the workbook protection password? I tried using the Password property of the Workbook object but it just returns a string of asterisks.

I have an excel workbook (w/ VBA code). The workbook is password protected so users don't accidentally delete sheets, change sheet names, insert new sheets, etc... I allow the users to do these through a dynamically created menu. So, their actions are controlled.

In order to do the changes, I use the ff code:

MyWorkbook.Unprotect ThePassword
'changes here... delete sheet, rename, insert, etc...
MyWorkbook.Protect ThePassword, True

I would like the user (admin for the particular excel file) to be able to specify the password...

Good Morning! For my first post, I'm going to ask something that's got me stumped. I've looked around and haven't found quite what I need, nor anything kind of close...

I have excel files that are generated from Autocad to a specified folder. I then have to move the sheets in this folder (in 1 or more workbooks) to a master workbook in a different folder. I have to do this a bunch of times for each project (things change and the master needs updating), and I have to do this over multiple projects. Currently, I open up the Autocad-generated WBs and rename the sheet to their filename, then manually move them over to the master WB (deleting any previous sheets that were created by this method). It seems like something fairly simple to do, but my VBA skills are seriously lacking, so I need some guidance.

A couple of notes regarding how this all works:
The file structure varies for each project, so I can't use a hard-coded folder reference, but I can use relative paths. In my case, the master WB is in a directory called "BOM_ItemList", while the Autocad-generated WBs are in a folder called "Misc". Each of these folders are in the same directory (i.e., "BOM_ItemList" and "Misc" are in a folder called "Units".The Autocad-generated WBs are named for the drawings they're produced from, so their filenames vary (although each sheet name is the standard "Sheet1"). However, I don't know that it matters, I need every xl file in that directory.
So I suppose my question is how do I copy all the sheets from all the XL files from the "Misc" directory to the master WB using a relative file paths? I've come across some code (included below) that seems close, but I don't know how to modify it to suit my needs. Any help and/or guidance would be greatly appreciated, as I do this a lot and it's tedious work.

Dim mypath As String 
mypath = ActiveWorkbook.Path & "..misc" 
Private Declare Function MeaningOfLife Lib mypath () As Long 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Sub RunCodeOnAllXLSFiles() 
    Dim lCount As Long 
    Dim wbResults As Workbook 
    Dim wbCodeBook As Workbook 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    On Error Resume Next 
    Set wbCodeBook = ThisWorkbook 
    With Application.FileSearch 
         'Change path to suit
        .LookIn = ActiveWorkbook.Path & "..misc" 
        .FileType = msoFileTypeExcelWorkbooks 
         'Optional filter with wildcard
         '.Filename = "*.xls"
        If .Execute > 0 Then 'Workbooks in folder
            For lCount = 1 To .FoundFiles.Count 'Loop through all
                 'Open Workbook x and Set a Workbook variable to it
                Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0) 
                 'DO YOUR CODE HERE
                wbResults.Close SaveChanges:=False 
            Next lCount 
        End If 
    End With 
    On Error Goto 0 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

I have two macros one of which imports the data and the other processes the data. These macros were created at different times and need to be joined into a single macro that will combine their operations – with slight modification to the importing macro. Let me describe what each of the macros does:

PROCESS macro:
Cycles through the CONTROL CELL on the “1” tab using the VALUES TO TEST. For each value to test it copies the values form the output tabs and pastes them into the A+B tab. Then it removes the duplicate rows there.

Sub PROCESS() 'This subroutine is called when clicking on the first button
    Dim i As Long, j As Long, k As Long 'Those are the variables that will browse through the whole sheets
    Dim l As Integer 'this will be used to browse through the values to test
    Dim TheSearch(1 To 2) As Object 'This is an array of objects that will be used for the search
    Dim TheRange As Range 'This will be used to flag the range of duplicates in the output
     'Searching for the Text string 'VALUES To TEST' in the sheet "1" in order to know where the array of values to be tested
    Set TheSearch(1) = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.Rows.Count + 10,
ActiveSheet.UsedRange.Columns.Count)).Find(What:="VALUES TO TEST", LookIn:=xlValues, Lookat:=xlWhole) 
     'If this search returned something then the references are defined
    If Not TheSearch(1) Is Nothing Then 
         'We further look the same way for the reference cell
        Set TheSearch(2) = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.Rows.Count + 10,
ActiveSheet.UsedRange.Columns.Count)).Find(What:="CONTROL CELL", LookIn:=xlValues, Lookat:=xlWhole) 
         'If this second search returned something, we have all references defined and may start the work
        If Not TheSearch(2) Is Nothing Then 
             'This is the loop to go through all all values: as long as the cell below TheSearch(2).Row are non-empty it
means that there is a value to test
            l = 1: While Trim(Cells(TheSearch(1).Row + l, TheSearch(1).Column))  "" 
             'Put the value to be tested in the control cell
            Cells(TheSearch(2).Row + 1, TheSearch(2).Column) = Cells(TheSearch(1).Row + l, TheSearch(1).Column) 
            Application.Calculation = xlManual 'Disable automatic calculation of the cells: the cells with Rand() won't
change value. Necessary to avoid continuously re-evaluating the cells and slowing down everything.
            Application.Calculate 'Evaluate once all formulas in the cells
            Application.ScreenUpdating = False 'Disable the refresh of the screen so that the user won't see the switching
between all sheets and so on
             'Find the data already present in sheet A+B: as long as the cells in the first column are non-empty, we increase
the counter "k" by one unit until we have found a blank cell. In this case the number of rows equals "k".
            k = 1: While Trim(AB.Cells(k, 1))  "": k = k + 1: Wend 
             'Copy data from A OUT
            AOUT.Select 'select the sheet "A OUT" - I have renamed the code of the sheet to "AOUT" so that this line is
equivalent to Sheets("A OUT").Select
            i = 1: While Trim(Cells(i, 2)) = "A": i = i + 1: Wend: i = i - 1 'Same as previously described: count the number
of used rows in sheet "A OUT" with a simple loop. In this case even in some rows are non-empty, we need to find out how many
cells get evaluated, which can be done with the condition that cells of the second column = "A"
            If i > 0 Then 'If there is at least one line of data - to avoid an error in the declaration below
                Range(Cells(1, 1), Cells(i, 13)).Copy 'Select and copy to clipboard the range that get evaluated, i.e. in
your sheet you have 14 columns starting from column 1, and i rows starting from row 1.
                AB.Select: Range(Cells(k, 1), Cells(k + i, 13)).Select: Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'Go to the sheet "A+B" (whose code I renamed to "AB"), select the
destination area (it has the same range as the area selected in the previous sheet), and paste as text - do not paste
everything since we do not want to paste the formulas, only the values.
            End If 
             'Copy data from B OUT
            BOUT.Select 'Exactly the same as above for "A OUT"
            j = 1: While Trim(Cells(j, 2)) = "B": j = j + 1: Wend: j = j - 1 
            If j > 0 Then 
                Range(Cells(1, 1), Cells(j, 13)).Copy 
                AB.Select: Range(Cells(k + i, 1), Cells(k + i + j, 13)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False 'Only difference here is that we have already pasted "k+i" lines of data (instead of "k"
previously), so that we shall paste the new lines after those "k+i" lines
            End If 
            S1.Select 'Go back to the sheet "1" (whose code I renamed to "S1"
            Application.Calculation = xlAutomatic 'enable automatic calculation of the cell (if not you may close Excel and
further forget you had disabled automatic calculation and get into some trouble)
            Application.ScreenUpdating = True 'Update the screeen refreshing
            l = l + 1 'Increase the counter for the data to be tested
         'Check for duplicate lines in "A+B" and erase them
        Application.Calculation = xlCalculationManual 'Again, avoid automatic calculation
        Application.ScreenUpdating = False 'Again, avoid refreshing screen
        Set TheRange = Nothing 'Initializing the range of dupes to nothing
        With AB 'with the sheet of code "AB" - averything that refers to a WITH statement comes fir a dot "." first
             'Very slow routine that is quadratic in the number of lines - if you want to increase the speed you may have to
use some tricks as hinted in the post by Colin
            i = 1: While Trim(.Cells(i, 1))  "" 'browsing all non-empty lines in the A+B sheet
            j = i + 1: While Trim(.Cells(j, 1))  "" 'for each line "i", looking for potential dupes that will come after line
i - it is necessary to go on after line i because if not all duplicate lines would be removed, including the original copy
            If .Cells(i, 1) = .Cells(j, 1) And .Cells(i, 2) = .Cells(j, 2) And .Cells(i, 13) = .Cells(j, 13) Then 'Those are
the conditions defining a duplicate line: same cells in columns 1, 2, and 14 (last column)
                If TheRange Is Nothing Then 'This IF condition is necessary to avoid using UNION command with a range that is
set to NOTHING (would produce an error)
                    Set TheRange = .Range(j & ":" & j) 'First dupe found: the range of dupes is defined by this only row
                    Set TheRange = Union(TheRange, .Range(j & ":" & j)) 'otherwise if some dupes were already found, the
range of dupes consists of the union of the new row with the previously found ones
                End If 
            End If 
            j = j + 1 'Increasing the counter for the dupes after line i
        i = i + 1 'Increasing the counter for the browsing of all lines in the output sheet
    If Not TheRange Is Nothing Then TheRange.EntireRow.Delete 'If we have found a dupe, then we erase all rows containing the
dupe - much faster to use this range command than erasing each line indivisually on the fly
End With 
S1.Select 'select again the main sheet "1"
Application.Calculation = xlAutomatic 'Enabling again automatic calculation
Application.ScreenUpdating = True 'Enabling again the refreshing of the screen
 'Finished the test: displaying a message to show that all "l-1" values were tested
MsgBox ("Done: all " & l - 1 & " values were tested and eventual duplicates removed.") 
 'did not find the reference cell: displaying a message such that there was an error
    MsgBox ("Could not find the string 'CONTROL CELL'.") 
End If 
 'did not find the values to test: displaying a message such that there was an error
    MsgBox ("Could not find the string 'VALUES TO TEST'.") 
End If 
End Sub 
Sub EraseAB() 'This subroutine is called whenclicking on the second button
    AB.Cells.ClearContents 'erase all contents of the sheet "A+B" (whose code I renamed to "AB")
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
IMPORT macro:
Imports the text from a specified folder and records the average of the last column along with the name of the text file. I need it to be plugged into the PROCESS macro with slight modification = it should import these text files into the A19 cell on the 1 tab and enter the name of the text file into the B17 cell on the same tab.

    Dim objFSO As Object 
    Dim objFolder As Object 
    Dim txtFile As Object 
    Dim writeToRow As Integer 
    Dim rn As Range 
    Dim myAverage As Double 
    writeToRow = 2 
    Worksheets(1).Cells(1, 1) = "File Name" 
    Worksheets(1).Cells(1, 2) = "Average Value" 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFSO.GetFolder("C:MyTemp") 
    For Each txtFile In objFolder.Files 
        Worksheets.Add before:=Worksheets(1) 
        Worksheets(1).Name = txtFile.Name 
        With Worksheets(1).QueryTables.Add(Connection:="TEXT;" & txtFile.Path, _ 
            .FieldNames = True 
            .RowNumbers = False 
            .FillAdjacentFormulas = False 
            .PreserveFormatting = True 
            .RefreshOnFileOpen = False 
            .RefreshStyle = xlInsertDeleteCells 
            .SavePassword = False 
            .SaveData = True 
            .AdjustColumnWidth = True 
            .RefreshPeriod = 0 
            .TextFilePromptOnRefresh = False 
            .TextFilePlatform = 850 
            .TextFileStartRow = 1 
            .TextFileParseType = xlDelimited 
            .TextFileTextQualifier = xlTextQualifierDoubleQuote 
            .TextFileConsecutiveDelimiter = True 
            .TextFileTabDelimiter = False 
            .TextFileSemicolonDelimiter = False 
            .TextFileCommaDelimiter = False 
            .TextFileSpaceDelimiter = True 
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1) 
            .TextFileTrailingMinusNumbers = True 
            .Refresh BackgroundQuery:=False 
        End With 
        Set rn = Range("F1", Range("F1").End(xlDown)) 
        Worksheets(1).Cells(1, 8) = "Average" 
        Worksheets(1).Cells(1, 9).Formula = "=AVERAGE(" & rn.Address & ")" 
        Worksheets(2).Cells(writeToRow, 1) = txtFile.Name 
        Worksheets(2).Cells(writeToRow, 2) = Round(Worksheets(1).Cells(1, 9).Value, 2) 
        writeToRow = writeToRow + 1 
        Application.DisplayAlerts = False 
        Application.DisplayAlerts = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I would gladly do this all on my own but I feel that my knowledge is limited for this task. I really hope you will be able to help me!


I have attached the each of the macros in its corresponding workbook and also a few text files for importing.

I've got the following piece of code:

            If Err  0 Then
                On Error GoTo 0
                ActiveSheet.Name = SheetName
            End If
TargetWorkBookName is (in this example) 'Book3' (I created it for testing the VBA)
SheetName = "In-cc"
It's there on the source workbook, I can manually change the sheetname but when I try and do it by VBA it crashes with error 1004 -
"WHilst renaming a sheet you entered an invalid name, make sure it does not contain /*?[ or ], does not exceed 31 characters and is not blank.
"In-cc" fails none of those tests.

Any ideas what's going wrong?

I'm copying named ranges from one sheet to another, so need toi ensure that the target sheet will be there when the name copies over. I'm doing this because a dept has a lot of spreadsheets migrated from Lotus123 in the distant past full of name ranges and a lot of the excel versions are corrupting. There are hundreds of these workbooks, and we don't have time to do it manually as the staff who are using them are being made redundant in 2 weeks when their work is trasferred to another dept..

Hi guys,

I've just bought VBA & Macros for MS Excel and am using it to help me automate one of our main weekly reports at work. All was going well until I came across this problem. I've spent hours on it but don't know what's wrong. Can anyone help?


The aim: Put a procedure in the main report workbook(A) that opens another workbook(B), copies and renames a sheet from it then saves a backup of (B) under a new name in a new directory before closing (B). I can get it to do everything except close(B) and I don't understand why it won't work. I'm using Excel '97.

The code:

Sub OpenAdditionalPages()

Application.Calculation = xlCalculationManual

Dim FullFilePath As String
Dim SpamName As String
Dim Drive As String
Dim DotCom As String
Dim DotComSave As String

'Identify the drive letter for shared drive and produce aliases for filenames
FullFilePath = ThisWorkbook.FullName
SpamName = ThisWorkbook.Name
Drive = Left(FullFilePath, 3)
DotCom = Drive & "Non Food Finance2005-06 ReportingSPAM~Master FolderCurrentWeek_DOTCOM.xls"
DotComSave = "DotCom WK" & [currentweek] & ".xls"

'Open DotCom file
Workbooks.Open FileName:=DotCom, UpdateLinks:=0

'Copy across 'Margin' sheet and rename '.Com'
Sheets("Margin").Copy Before:=Workbooks(SpamName).Sheets("REPORT")
Sheets("Margin").Name = ".Com"

'Save and close DotCom file

With ActiveWorkbook
.SaveCopyAs FileName:= _
Drive & "Non Food Finance2005-06 ReportingSPAMDotCom Pages" & DotComSave
End With

Application.Calculation = xlCalculationAutomatic

End Sub


Your code worked for me with Windows 2000, XL2002.

This also worked.

Sub DeleteAndCopy()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet, ws1 As Worksheet, x As String
Set ws1 = Sheets("Inquiry Form ")
x = ws1.Name
Set ws = Sheets.Add
ws.Move after:=ws1
ws1.Rows("1:100").Copy ws.Range("A1")
ws.Name = x
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


wrote in message
| With apologies to those who may have answered similar questions in the
| past... problem for me it that I just can not get this to work.
| Background: VBA code was developed under Win95 (yes, client still has
| Win95 machines) in Excel-97 where it seems to work just fine. On a NT
| machine with Excel-97 it seems to work but this the code is not fully
| tested on that machine. Under Win2000 with Excel 2002, the code does
| not work. It steps through certain code but make no change to the
| worksheet(s).
| Issue:
| Add a new worksheet, copy first 100 rows from an existing sheet, same
| workbook to the first 100 rows of new sheet, delete the original
| sheet, rename the new sheet to the old sheet name (.delete and .name
| statements do nothing).
| Application.Sheets.Add Type:="Worksheet"
| Application.ActiveSheet.Move after:=Worksheets("Inquiry Form ")
| Application.ActiveSheet.Name = "NewInquiryForm"
| Sheets("Inquiry Form ").Rows.("1:100").Copy
| Sheets("NewInquiryForm").Activate
| Range("A1").Select
| ActiveSheet.Paste
| Sheets("Inquiry Form ").Activate
| ActiveWindow.SelectedSheets.Delete
| Sheets("NewInquiryForm").Activate
| Sheets("NewInquiryForm").Name = "Inquiry Form "
| When the above .delete and .name statements did nothing, I also tried:
| Sheets("Inquiry Form ").Activate
| ThisWorkBook.Names("Inquiry Form ").Delete
| Sheets("NewInquiryForm").Activate
| ThisWorkBook.Names("NewInquiryForm").Name = "Inquiry Form "
| Any assistance would be greatly appreciated!
| Thanks,
| Ron


First off let me say that I've had previous programming experience in C++ and C#, but never before messed with Excel VBA. So I get most of the logic, I'm just struggling with some of the syntax.

Here's what I'm working with:
I have a worksheet "MAINFORM" with a certain number of predefined ticker symbols (starting at A3 going down). This number will be anywhere between 100-200 ticker symbols.
When I press a button, it should download two CSV files for each ticker symbol.
For every ticker symbol, it pastes the data from the CSV files into a single worksheet (the first file gets pasted into a range starting with cell A2, the second file gets pasted into a range starting with cell I2).

Each CSV file is between 1KB and 4KB, so theoretically the download should take just a few seconds even if it's downloading CSV files for a hundred ticker symbols.
But currently what I have written is very slow (takes about 30 seconds to download everything).

I started out with a module that someone else wrote, it was sent to me in an email as an example to start out with:

    Dim QuerySheet As Worksheet 
    Dim DataSheet As Worksheet 
    Dim qurl As String 
    Dim i As Integer 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.Calculation = xlCalculationManual 
    Set DataSheet = ActiveSheet 
    i = 7 
    qurl = "" + Cells(i, 1) 
    i = i + 1 
    While Cells(i, 1)  "" 
        qurl = qurl + "+" + Cells(i, 1) 
        i = i + 1 
    qurl = qurl + "&f=" + Range("C2") 
    Range("c1") = qurl 
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("C7")) 
        .BackgroundQuery = True 
        .TablesOnlyFromHTML = False 
        .Refresh BackgroundQuery:=False 
        .SaveData = True 
    End With 
    Range("C7").CurrentRegion.TextToColumns Destination:=Range("C7"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=True, Space:=False, other:=False 
    With ThisWorkbook 
        For Each nQuery In Names 
            If IsNumeric(Right(nQuery.Name, 1)) Then 
            End If 
        Next nQuery 
    End With 
     'turn calculation back on
    Application.Calculation = xlCalculationAutomatic 
    Application.DisplayAlerts = True 
     '    Range("C7:H2000").Select
     '    Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
     '        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Columns("C:C").ColumnWidth = 25.43 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I read through that and modified it to fit my purposes. But there are a few things in it that I didn't really understand.
Here's what my final code looks like:

    Dim i As Integer 'counter to loop through tickers
    Dim wsName As String 'variable for ticker symbol, used to identify worksheets
     'pasted code
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.Calculation = xlCalculationManual 
    i = 3 
    While Cells(i, 1)  "" 'loop through the ticker symbols
        wsName = Cells(i, 1) 'set the var to the name of the ticker
        CreateNewWorksheet (wsName) 'create a new worksheet for each ticker
        Sheets(wsName).Select 'select the appropriate worksheet
        GetData (wsName) 
        GetDivs (wsName) 
        i = i + 1 'increment the counter
     'turn calculation back on
    Application.Calculation = xlCalculationAutomatic 
    Application.DisplayAlerts = True 
    MsgBox "Download complete." 
End Sub 
Sub GetData(wsName As String) 
    Dim DataSheet As Worksheet 
    Dim qurlPrefix As String 
    Dim qurlSuffix As String 
    Dim qurl As String 
    qurlPrefix = "" 
    qurlSuffix = "&a=00&b=1&c=2005&d=06&e=26&f=2010&g=m&ignore=.csv" 'TODO: Dynamic end date (i.e. today's date)
    qurl = qurlPrefix + wsName + qurlSuffix 
    Set DataSheet = ActiveSheet 
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("A2")) 
        .BackgroundQuery = True 
        .TablesOnlyFromHTML = False 
        .Refresh BackgroundQuery:=False 
        .SaveData = True 
    End With 
    Range("A2").CurrentRegion.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=True, Space:=False, other:=False 
    With ThisWorkbook 
        For Each nQuery In Names 
            If IsNumeric(Right(nQuery.Name, 1)) Then 
            End If 
        Next nQuery 
    End With 
End Sub 
Sub GetDivs(wsName As String) 
    Dim DataSheet As Worksheet 
    Dim qurlPrefix As String 
    Dim qurlSuffix As String 
    Dim qurl As String 
    qurlPrefix = "" 
    qurlSuffix = "&a=00&b=1&c=2005&d=06&e=26&f=2010&g=v&ignore=.csv" 'TODO: Dynamic end date (i.e. today's date)
    qurl = qurlPrefix + wsName + qurlSuffix 
    Set DataSheet = ActiveSheet 
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("I2")) 
        .BackgroundQuery = True 
        .TablesOnlyFromHTML = False 
        .Refresh BackgroundQuery:=False 
        .SaveData = True 
    End With 
    Range("I2").CurrentRegion.TextToColumns Destination:=Range("I2"), DataType:=xlDelimited, _ 
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
    Semicolon:=False, Comma:=True, Space:=False, other:=False 
    With ThisWorkbook 
        For Each nQuery In Names 
            If IsNumeric(Right(nQuery.Name, 1)) Then 
            End If 
        Next nQuery 
    End With 
End Sub 
Sub CreateNewWorksheet(wsName As String) 
    Dim oSheet As Worksheet, vRet As Variant 
    On Error Goto errHandler 
     'creating a new excel worksheet called wsName
    Set oSheet = Worksheets.Add 
    With oSheet 
        .Name = wsName 
    End With 
    Exit Sub 
     'if error due to duplicate worksheet detected
    If Err.Number = 1004 Then 
         'delete the old worksheet
        Application.DisplayAlerts = False 
        Application.DisplayAlerts = True 
         'rename and activate the new worksheet
        With oSheet 
            .Name = wsName 
        End With 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I was reading the stickies at the top of this forum and I came across the Golden Rule thread.
It mentioned a few things that caught my eye, namely "Don't use manual calculations".

But even though my code is working, and I (vaguely) understand it, I have no idea how to optimize it and make it run faster.
I know I don't need two separate subs for functions that accomplish pretty much the same thing (GetData and GetDivs, they have slightly different URLs and they import to a different range). However when I tried to pass more than one argument to the GetData sub to differentiate which CSV I wanted it to download, excel gave me an error (something along the lines of " '=' expected " ).

Along those lines, every time either function is called it looks like it opens a new query and deletes it, which looks like it wastes time and CPU when I could have some kind of loop inside it and re-use it maybe?

How can I send more than one argument to a sub? (I've searched, found nothing relevant... must be wording it incorrectly)
How can I condense these hundreds of queries into possibly one query?
What should I use instead of "manual calculations"?
Can anyone give me any other pointers or suggestions?


Good Morning,

I use excel to perform iterative engineering simulations. I've made a user form that allows the user to input simulation names and select sheets in the workbook to be duplicated, renamed, and then moves all of the internal links between the simulations to the new "duplicated" worksheets.

My problem starts when the .Replace portion of the code runs. I get a 1004 error and I'm not certain why, it just highlights the entire .Replace statement in debug mode.

    Dim WSheetOld(1 To 20) As String 'Variable Holding The Old Sheet Names
    WSheetOld(1) = lblWorksheet1.Caption 'Fill the variables with data from the
    WSheetOld(2) = lblWorksheet2.Caption 'labels
    WSheetOld(3) = lblWorksheet3.Caption 
    WSheetOld(4) = lblWorksheet4.Caption 
    WSheetOld(5) = lblWorksheet5.Caption 
    WSheetOld(6) = lblWorksheet6.Caption 
    WSheetOld(7) = lblWorksheet7.Caption 
    WSheetOld(8) = lblWorksheet8.Caption 
    WSheetOld(9) = lblWorksheet9.Caption 
    WSheetOld(10) = lblWorksheet10.Caption 
    WSheetOld(11) = lblWorksheet11.Caption 
    WSheetOld(12) = lblWorksheet12.Caption 
    WSheetOld(13) = lblWorksheet13.Caption 
    WSheetOld(14) = lblWorksheet14.Caption 
    WSheetOld(15) = lblWorksheet15.Caption 
    WSheetOld(16) = lblWorksheet16.Caption 
    WSheetOld(17) = lblWorksheet17.Caption 
    WSheetOld(18) = lblWorksheet18.Caption 
    WSheetOld(19) = lblWorksheet19.Caption 
    WSheetOld(20) = lblWorksheet20.Caption 
    Dim WSheetNew(1 To 20) As String 'Variable Holding The New Sheet Names
    Dim SlimSheetName(1 To 20) As String 
    Dim Counter As Integer 'Variable counting the number of sheets
    Dim NewSheetCounter As Integer 'Variable for counting the WSheetNew Array value
    Dim DummyCounter As Integer 
    Dim YetAnotherCounter As Integer 
    Dim StartPosition As Integer 
    Dim EndPosition As Integer 
    Dim ReplaceValues(1 To 16) As String 'Values that will be stripped from the sheet name
    ReplaceValues(1) = " Basecase" 'Any of these values will be removed from the sheet name
    ReplaceValues(2) = " Baseline" 'when they are cloned.
    ReplaceValues(3) = " Base case" 
    ReplaceValues(4) = " Base line" 
    ReplaceValues(5) = " Base-case" 
    ReplaceValues(6) = " Base-line" 
    ReplaceValues(7) = " Base" 
    ReplaceValues(8) = " Pre" 
    ReplaceValues(9) = "Basecase" 'Any of these values will be removed from the sheet name
    ReplaceValues(10) = "Baseline" 'when they are cloned.
    ReplaceValues(11) = "Base case" 
    ReplaceValues(12) = "Base line" 
    ReplaceValues(13) = "Base-case" 
    ReplaceValues(14) = "Base-line" 
    ReplaceValues(15) = "Base" 
    ReplaceValues(16) = "Pre" 
    Dim MeasureNumber As String 
    Dim MeasureNumberSize As String 
    Dim Thing As Integer 
    Dim Item As Integer 
    Dim ItemCounter As Integer 
    If obEEM.Value = True Then 
        MeasureNumber = SummaryTextStart & "(EEM-" & txtMeasureNumber.Value & ") " 
    ElseIf obNCM.Value = True Then 
        MeasureNumber = SummaryTextStart & "(NCM-" & txtMeasureNumber.Value & ") " 
    ElseIf obLCM.Value = True Then 
        MeasureNumber = SummaryTextStart & "(LCM-" & txtMeasureNumber.Value & ") " 
    ElseIf obCIM.Value = True Then 
        MeasureNumber = SummaryTextStart & "(CIM-" & txtMeasureNumber.Value & ") " 
    ElseIf obRCx.Value = True Then 
        MeasureNumber = SummaryTextStart & "(RCx-" & txtMeasureNumber.Value & ") " 
    End If 
    Counter = 1 
    DummyCounter = 1 
    Item = 1 
    For Item = 1 To 20 
        Item = Item + 1 
        If WSheetOld(Counter)  "" Then 
            If Left(WSheetOld(Counter), 8) = "(" & MeasureNumber & ")" And Len(txtMeasureNumber.Value) = 1 Then 
                MsgBox ("Your measure number has already been used in this document. Please change the measure number.") 
                Goto ExitRename 
            ElseIf Left(WSheetOld(Counter), 9) = "(" & MeasureNumber & ")" And Len(txtMeasureNumber.Value) = 2 Then 
                MsgBox ("Your measure number has already been used in this document. Please change the measure number.") 
                Goto ExitRename 
            ElseIf Left(WSheetOld(Counter), 10) = "(" & MeasureNumber & ")" And Len(txtMeasureNumber.Value) = 3 Then 
                MsgBox ("Your measure number has already been used in this document. Please change the measure number.") 
                Goto ExitRename 
            End If 
            Counter = Counter + 1 
        End If 
    Counter = Counter - 1 'Adjusts the counter number down to correct value
    For NewSheetCounter = 1 To Counter 
        ItemCounter = 1 
        SlimSheetName(NewSheetCounter) = WSheetOld(NewSheetCounter) 
        For ItemCounter = 1 To 16 
            SlimSheetName(NewSheetCounter) = Replace(SlimSheetName(NewSheetCounter), ReplaceValues(ItemCounter), "") 
        With Sheets(WSheetOld(NewSheetCounter)) 
            .Copy After:=Sheets(Sheets.Count) 'Lets update this to make it the last sheet of the copied sheets
        End With 
        WSheetNew(NewSheetCounter) = MeasureNumber & SlimSheetName(NewSheetCounter) 
        ActiveSheet.Name = WSheetNew(NewSheetCounter) 
    NewSheetCounter = 1 
    For NewSheetCounter = 1 To Counter 
        Dim LastRow As Long 
        Dim FirstRow As Long 
        Dim LastCol As Integer 
        Dim FirstCol As Integer 
        Dim FirstRange As String 
        Dim LastRange As String 
        For DummyCounter = 1 To Counter 
            YetAnotherCounter = 1 
             ' Find the FIRST real row
            FirstRow = ActiveSheet.Cells.Find(What:="*", _ 
            SearchDirection:=xlNext, _ 
             ' Find the FIRST real column
            FirstCol = ActiveSheet.Cells.Find(What:="*", _ 
            SearchDirection:=xlNext, _ 
             ' Find the LAST real row
            LastRow = ActiveSheet.Cells.Find(What:="*", _ 
            SearchDirection:=xlPrevious, _ 
             ' Find the LAST real column
            LastCol = ActiveSheet.Cells.Find(What:="*", _ 
            SearchDirection:=xlPrevious, _ 
             'Select the ACTUAL Used Range as identified by the
             'variables identified above
            FirstRange = Cells(FirstRow, FirstCol).Address 
            LastRange = Cells(LastRow, LastCol).Address 
            MsgBox (FirstRange & ":" & LastRange) 
            Worksheets(WSheetNew(NewSheetCounter)).Range(FirstRange, LastRange) _ 
            .Replace What:=WSheetOld(YetAnotherCounter), _ 
            Replacement:=WSheetNew(YetAnotherCounter), LookIn:=xlFormulas, _ 
    Unload usrAddEEM 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I'd appreciate any help you can provide.


I have a short excel sheet where different departments have to input some data.

I am kind of new in VBA programming, so I mainly copy pieces of written macros and paste them together.
I have a "save as" macro so that we have a standard/sequential file name:

Sub saveas()
If MsgBox("blablabla", vbYesNo) = vbNo Then Exit Sub
With Application
.DefaultFilePath = "C:"
End With
ThisFile = Range("E40").Value
FileDrive = Range("E41").Value
ActiveWorkbook.saveas Filename:=FileDrive & ThisFile & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

E41 has the standard path written (a shared drive).
E40 has a formula that creates a filename from the data entered in the sheet.

As this filename may change a bit everytime a different Dept. enters pieces of data, saving it every time with this macro is a good tool for showing what the completeness status is for these forms, just by having a glance at the filename.

My problem is that this generates a lot of duplicate files, since it only creates a new file, not replacing the old one.
I have:
...where I just wanted to have the 3xxxxxx.xls, which is the most recent one.

is it possible to have this macro work in a way so that if the filename has changed it just replaces the current name instead of duplicating?

How could I adapt this code to get the results I expect?

Thanks in advance,

Hello - - I have an excel file that contains about 1000 rows of data, from column A to O. Column C contains either the letter A or the letter I, A means Active, I means Inactive.

What I'd like to do is replace my monthly manual task of moving all the I's to sheet2. When completed, the excel file should have two sheets, all of the A's on one, and the I's in the other. The original excel file is not sorted by column C. The end result should have the same row 1, being the header row.

Any suggested VBA code to get this started would be great! There are some additional steps, to save the file to a specific location but I think I could do that once the excel file is formatted the way I wanted it....

Thanks again for your help....!

Hey all - - Thanks for all your replies, I did however find a workable solution from Ron B.'s it is, a bit longer then other suggestions - - I did add in the save and copy commands at the end:

Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim ErrNum As Long

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A1:O2000") '  & LastRow(ActiveSheet))

    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    'This example filters on the first column in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 3 ' I changed this to 3 for column C

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Range.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
             Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"),
"?", "~?")

            'Check if there are no more then 8192 areas(limit of areas)
            CCount = 0
            On Error Resume Next
            CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
            On Error GoTo 0
            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
                'Add a new worksheet
                Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = cell.Value
                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                End If
                On Error GoTo 0

                'Copy the visible data to the new worksheet
                With WSNew.Range("A1")
                    ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                    ' Remove this line if you use Excel 97
                    .PasteSpecial Paste:=8
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If

            'Show all data in the range
            My_Range.AutoFilter Field:=FieldNum

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    MsgBox ("Copy Complete - - Now saving file to T:Job Code folder")
    FileCopy "T:Job CodesActive Job Codes.xls", _
"T:Job CodesArchiveActive Job Codes " & Format(Now(), "yyyy - mm") & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:="T:Job CodesActive Job Codes" & ".xls"
MsgBox ("Active Job Code Now Saved the T Drive")

End Sub
Thanks again...I'm closing this with Solved!!!

Hi Friends,

I've been trying to code a macro to batch rename files in a specific folder...

What I have with me is a simple excel sheet containing old file names, and new file names along side. Any clues as to how to do it?

I have *tried* to make the following code, but considering its one of my first VB codes, its bound to be full of errors.

For the moment, it is failing to attach the path to the file name. keeps returning a filename.xls cannot be found.

thanks in advance

Sub BacthFileRenamerFirstWords()
Dim PathToUse As String
Dim myDoc As Workbook
Dim NewName As String
Dim OldName As String
Dim SomeName As String
Dim i As Long
   PathToUse = "C:Documents and Settingsnehastest2"
   x = ActiveCell.Row
   Do While Cells(x, 1).Value <> ""
   SomeName = Path2Use & "" & Cells(x, 1).Value
      Set myDoc = Application.Workbooks.Open(SomeName)
     With myDoc
           OldName = .FullName
            NewName = Cells(x, 4).Value
            Name OldName As PathToUse & NewName & ".xls"
      End With
      Exit Do
     x = x + 1
    Application.ScreenUpdating = False
    End Sub

Hey folks,

I am fairly new to VBA coding in Excel and I am trying compile a script that will allow me to copy an existing worksheet and rename it based off of values referenced in the range A2:A54 in another worksheet.

Here is an overview:

1. Worksheet to copy - "Template"
2. Worksheet with range for renaming - "Weekly Overview"
3. Cell range for renaming - "A2:A54"
4. Values in the cells are as follows - A:2 = 1/4/10, A:3 = A2+7, A:4 = A3+7, etc.
5. The issue I am having is the fact that the values in the cells are formatted as date and have a 7 day increment (basically, each cell lists the first day of each week)
6. I would like to keep the formatting "MM-DD-YYYY" in the tab name

This is what I have so far:
Sub Copy_Sheets()
    Dim i As Integer
    Dim wks As Worksheet
    Set wks = Sheets("Weekly Overview")
    For i = 2 To 54
        Sheets("Template").Copy After:=Sheets(3)
        ActiveSheet.Name = wks.Cells(i, 1)
        ActiveSheet.Cells(1, 2) = wks.Cells(i, 1)
End Sub

This currently fails because of the "/" in the date format even though I have a custom format of "MM-DD-YYYY" on the cell range.

Any help with this one would be greatly appreciated.

I'm using VBA code to create a excel file dynamically from my VB6.0 application in scenario as below...

I have a detail recordset for which i need to create seperate sheet for each record in the same workbook. i.e., Excel.xls file i should have 10 sheets added if 10 record exist. Also i want the rename the sheet i.e. M1-Details for Sheet1 like wise...

can you pls suggest me to accomplish this.

Tnx in Advance

I am a rookie in Excel macros. I am just taking over an application that was developed in Excel 4.0 macro ages ago and the company does not have the time or resources to re-code the whole thing in VBA. But they want the same Excel 4.0 macro application to run in Office 2007.

This 4.0 macro runs commands like
 which in a pre-Excel 2007 setup, used to delete the "Format - Sheet - Rename" option. Later in the code it goes
ahead and adds its own macro for this "Format - Sheet - Rename" option. As I understand, the "5, 4, 1" in
the command indicated to select the fifth menu from left, four menu down and first menu, which happens to be "Format (5)
- Sheet (4) - Rename (1)" option.

With Excel 2007 ribbon style, the Sheet Rename option is no longer at this position. So, what is the kind of equivalent by which I can achieve this same functionality in Excel 2007? Any suggestion to resolve this issue would be highly appreciated.

Did lots of googling and did not find anything helpful between Excel 4.0 macro and Excel 2007. Any helpful links in this direction would also be highly appreciated.


Hi all,
I have spent around a month trying to find an appropriate solution to the task below but it’s been to no avail.

I have a workbook called ‘Data Sheet’ which contains a list of employee names (120+), which shift pattern they work, their managers names and individual stats based on their performance in a given quarter. I have spent a lot of time working on this so that these stats are pulled from various different sources rather than manually keyed – Progress!

At the end of the quarter every manager needs to create a workbook with a 2 sheet performance review for each of their employees. (i.e. 100 employees with 10 managers would result in 10 workbooks being created with 20 sheets in each). This process is currently manual and very time consuming.

To complicate things further, depending on what shift the employee works (D,R or DP) one of three different templates are needed.

I would like to have some VBA that does the following:
• Look to see how many employees in the ‘Data Sheet’ are managed by a particular manager.
• Of those employees, look to see if their shift is “D”, “R” or “DP”.
• Create a new workbook and copy the correct 2 page template (based on their shift) into it for each employee managed by that manager.
• Rename the first page of each template to the employee name.
• Rename the second name of each template to the employee name + “Disc”.
• Fill in each template using the relevant employees data contained in the ‘Data Sheet’ workbook.
• Save the work book as the manager name.
• Do the same for the next manager and so on.

I know this is a big task but I would really appreciate someone’s genius on this.

I have tried a lot of different coding and it’s now got to a point where I’m out of ideas and need to start again.

Thank you.

I have also posted this on the excelforum

During some progressive migration of VBA projects from older 2003 versions of Excel and Office in general, the code below seems to work ok in VBA 2003,
but does not work in Excel 2007
The name of the worksheet was Sheet1 in 2003, but the only chnage I done was rename the new workbooks worksheet.
It is simply supposed to add a number sequence in Column A if any of the cells have values in them in Column B
The total rows are not always the same, sometimes there might be up 150 rows of data, other times as low as 7.
So it would end up looking something like:

Column A-----Column B
RANK-------- TITLE
or other times
--infinately ( average upto 150, ~)

Sub RANK_NO() 
    For i = 1 To LastRow 
        Worksheets("SCRAP").Cells(i, 1).Value = i - 1 
        Worksheets("SCRAP").Range("A1").FormulaR1C1 = "RANK" 
    Next i 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


The following code does what I want to do except for one minor bug. What I want it to do is to ask me to select a folder, and then go in and retrieve the first worksheet from all workbooks in that folder and organize those worksheets into to one master workbook. It does all of that fine but what it doesn't do as I would like is to name the individual worksheets in the new workbook after the source workbook's file name. It does it for some of them (where the worksheet is "filename.xls" but not for all. Is there some code I can add to specify to name the new worksheets after the original file name--OR is there code where I can name the newly created worksheets (within the newly created master workbook) after a specific cell within those individual worksheets?

I'm slowly getting better at VBA but still not there yet so any help would be appreciated.


'The example below will copy the first worksheet from each file in a new workbook
'It copy as values because the PasteAsValues argument = True

'First we call the Function "Get_File_Names" to fill a array with all file names
'There are three arguments in this Function that we can change

'1) MyPath = the folder where the files are
'2) Subfolders = True if you want to include subfolders
'3) ExtStr = file extension of the files you want to merge
' ExtStr examples are: "*.xls" , "*.csv" , "*.xlsx"
' "*.xlsm" ,"*.xlsb" , for all Excel file formats use "*.xl*"
' Do not change myReturnedFiles:=myFiles

'Then if there are files in the folder we call the macro "Get_Sheet"
'There are three arguments in this macro that we can change

'1) PasteAsValues = True to paste as values (recommend)
'2) SourceShName = sheet name, if "" it will use the SourceShIndex
'3) SourceShIndex = to avoid problems with different sheet names use the index (1 is the first worksheet)
' Do not change myReturnedFiles:=myFiles
'DT: this is the macro that asks which file to look in then retrieves and coallates all excel files
' (in the selected folder) into a new single workbook

    Dim myFiles As Variant 
    Dim myCountOfFiles As Long 
    Dim oApp As Object 
    Dim oFolder As Variant 
    Set oApp = CreateObject("Shell.Application") 
     'Browse to the folder
    Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512) 
    If Not oFolder Is Nothing Then 
        myCountOfFiles = Get_File_Names( _ 
        MyPath:=oFolder.Self.Path, _ 
        Subfolders:=False, _ 
        ExtStr:="*.xl*", _ 
        If myCountOfFiles = 0 Then 
            MsgBox "No files that match the ExtStr in this folder" 
            Exit Sub 
        End If 
    End If 
    Get_Sheet _ 
    PasteAsValues:=False, _ 
    SourceShName:="", _ 
    SourceShIndex:=1, _ 
End Sub 
 ' Note: You not have to change the macro below, you only
 ' edit and run the RDB_Copy_Sheet above.
Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _ 
    SourceShIndex As Integer, myReturnedFiles As Variant) 
    Dim mybook As Workbook, BaseWks As Worksheet 
    Dim CalcMode As Long 
    Dim SourceSh As Variant 
    Dim sh As Worksheet 
    Dim i As Long 
     'Change ScreenUpdating, Calculation and EnableEvents
    With Application 
        CalcMode = .Calculation 
        .Calculation = xlCalculationManual 
        .ScreenUpdating = False 
        .EnableEvents = False 
    End With 
    On Error Goto ExitTheSub 
     'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
     'Check if we use a named sheet or the index
    If SourceShName = "" Then 
        SourceSh = SourceShIndex 
        SourceSh = SourceShName 
    End If 
     'Loop through all files in the array(myFiles)
    For i = LBound(myReturnedFiles) To UBound(myReturnedFiles) 
        Set mybook = Nothing 
        On Error Resume Next 
        Set mybook = Workbooks.Open(myReturnedFiles(i)) 
        On Error Goto 0 
        If Not mybook Is Nothing Then 
             'Set sh and check if it is a valid
            On Error Resume Next 
            Set sh = mybook.Sheets(SourceSh) 
            If Err.Number > 0 Then 
                Set sh = Nothing 
            End If 
            On Error Goto 0 
            If Not sh Is Nothing Then 
                sh.Copy after:=BaseWks.Parent.Sheets(BaseWks.Parent.Sheets.Count) 
                On Error Resume Next 
                ActiveSheet.Name = mybook.Name 
                On Error Goto 0 
                If PasteAsValues = True Then 
                    With ActiveSheet.UsedRange 
                        .Value = .Value 
                    End With 
                End If 
            End If 
             'Close the workbook without saving
            mybook.Close savechanges:=False 
        End If 
         'Open the next workbook
    Next i 
     ' delete the first sheet in the workbook
    Application.DisplayAlerts = False 
    On Error Resume Next 
    On Error Goto 0 
    Application.DisplayAlerts = True 
     'Restore ScreenUpdating, Calculation and EnableEvents
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
        .Calculation = CalcMode 
    End With 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

Hi there. I am seeking some urgent advice from all of you VBA gurus…
I have a large spreadsheet written in excel but am struggling with my last macro.
I have done lots of formulas in this workbook but cannot get the last VBA to work properly.
I have tried Loop macros, Offset macros and ranges but cannot get it to copy next number down.
I have simplified the workbook (see below) and will change the code to suit the proper workbook.
Basically I need a macro, which looks down column “C” for a membership number, Copies the Membership number in C4 into Cell F4 (which then generates a specific data field) range H4:L46 Say.
Copy that data field into another workbook, (say Book2), renames the sheet with the membership number originally copied from (Book 1, Cell C4)
Then looks to see if Cell C5 has a membership number in. If it has it takes this number, Copies it then pastes it into Cell F4 again (which then updates the data field with new details)
Copies that data field into workbook (Book2) again into a new Sheet and renames that sheet with the copied membership number.
Basically I want it to run down column C and every time it has a number filled in, it copies that number and pastes it into Cell F4 (which generates my data field) then copy that data field into a new workbook (Book2) and renames the sheets respectively. And stops when there are no more new membership numbers.
And to finish it off…….. Say I get more members (which generates more membership numbers) or I make changes to one of the memberships already copied and run the macro again.
I would like it to UPDATE the original coped sheet in Book2 with the new data, rather than ignoring it because it already exists…
Any help would be appreciated…
Thanks again


Workbook has approximately 30 worksheets and sheets can be inserted, renamed or deleted. Desire is to devise a simple means of navigating all worksheets in the workbook from any worksheet in the workbook. The navigational means has to remain with the workbook so that it can be used by anyone that opens the workbook. The first thought was to incorporate something into the Excel ribbon or Quick Access Toolbar, but that does not meet the need for navigation control to easily travel with the workbook. The second idea is to place a combobox control on each page or an appearance of the combobox that hovers over any worksheet that is selected. The combobox would be a drop down that would list every current worksheet in the workbook and would be dynamically updated as worksheets are inserted, deleted or renamed. The next action that should take place after the dropdown button on the combobox is clicked, would be user selection of the desired worksheet to navigate to and would change to that worksheet when selected from the dropdown list.

I've not been able to find any vba code samples for a combobox that will simply list and navigate to the selected worksheet. The second challenge is to have this navigational device available on all worksheets regardless of worksheets being inserted, deleted or renamed.



No luck finding an answer? You could always try Google.