I am trying to write a For...Next loop to create a set number of Worksheets in a Workbook. The the number of worksheets is set by the user from a dashboard, at an earlier point.
Can somebody point me in the right direction? This is my code, so far:
For i = 1 To siteCount
'I know the below won't work, and I also tried site_ & i, but no luck
Set site_i = Sheets.Add(after:=Sheets(Worksheets.Count))
site_i.Name = "Sheet Name"
Next i
With some small adjustments, your code will basically work:
Option Explicit
Sub AddSheets()
Dim siteCount As Integer
Dim i As Integer
Dim site_i As Worksheet
siteCount = 4
For i = 1 To siteCount
Set site_i = Sheets.Add(after:=Sheets(Worksheets.Count))
site_i.Name = "Sheet_Name_" & CStr(i)
Next i
End Sub
Related
I have an issue with my VBA script which I'm not able to resolve, despite of all the researches I've made (Indeed, I tried to modify all the vba scripts which were near what I'm looking for, but it doesn't work).
Thank you very much for your help !
I have 2 sheets.
For the first one (ActiveSheet), I have a list.
For example :
Beurre
Creme fraiche
Fromage
Oeufs
Yaourts
In the second one ("Add value"), I have this list :
Chocolat
Carotte
Haricot
Fromage
Endive
I want the script to verify if the first value which is the sheet ("Add Value") exists in the ActiveSheet.
If it doesn't, it takes the second value in "Add Value" to make this verification. And so on with the other lines.
The loop has to stop when the script finds the same value. Then it does an action (MsgBox, for example).
For example, when the script researches "Chocolat" (the first line of the sheet "Add Value") in the ActiveSheet, it won't find it : it will use the second word to make this reasearch until it uses world "Fromage" which also exist in the second sheet.
It does the action (the msgbox), then quit the loop to continue with the other called macro which are in the script.
Moreover, I would like to choose the columns of the cell from "Add Value" each time I call the macro. Indeed, there will be several lists in this sheet.
Here is my macro. The issue is that I get the error 424 on the ligne If Not FindString Is Nothing Then
Public Sub Var()
Dim plage As Variant
Set plage = ActiveSheet.Range("A:A")
Dim col As Integer
Dim Ligne As Integer
Set Ligne = 2
Dim FindString As String
Set FindString = ThisWorkbook.Sheets("Add Value").Cells(Ligne, col).Value
End Sub
Sub Boucle_Ajout(col)
With plage
Do
If Not FindString Is Nothing Then
'do
Else
Ligne = Ligne + 1
End If
Loop While Not FindString Is Nothing
End With
End Sub
Then when I call the Macro, I only have to choose the column.
For example :
Call Boucle_Ajout(1)
Thank you very much for your help, because I am sick of not finding the solution.
PS : sorry for my english, I'm french.
Assuming the lines without numbers are in A1 to A5, this works:
Option Explicit
Const THECOLUMN = "A1"
Sub FindLineInOtherSheet()
Dim activeSheetRange As Range
Dim addValueRange As Range
Dim activeSheetLastRow As Integer
Dim addValueLastRow As Integer
Dim i As Integer
Dim n As Integer
Dim activeSheetCell As String
Dim addValueCell As String
'*
'* Setup
'*
Set activeSheetRange = ThisWorkbook.Sheets("activeSheet").Range(THECOLUMN)
activeSheetLastRow = findLastRow("activeSheet", THECOLUMN)
addValueLastRow = findLastRow("addValue", THECOLUMN)
'*
'* Loop through each cell in addValue for each cell in activeSheet
'*
For i = 1 To activeSheetLastRow
Set addValueRange = ThisWorkbook.Sheets("addValue").Range(THECOLUMN)
activeSheetCell = activeSheetRange.Value
For n = 1 To addValueLastRow
addValueCell = addValueRange.Value
If addValueCell = activeSheetCell Then
MsgBox ("Trouvé " & addValueCell)
End If
Set addValueRange = addValueRange.Offset(1, 0) 'Next row
Next n
Set activeSheetRange = activeSheetRange.Offset(1, 0)
Next i
End Sub
Function findLastRow(Sheetname As String, ColumnName As String) As Integer
Dim lastRow As Integer
Dim r As Range
Dim WS As Worksheet
Set WS = Worksheets(Sheetname)
lastRow = WS.UsedRange.Rows.Count
'*
'* Search backwards till we find a cell that is not empty
'*
Set r = WS.Range(ColumnName).Rows(lastRow)
While IsEmpty(r)
Set r = r.Offset(-1, 0)
Wend
lastRow = r.Row
Set WS = Nothing
findLastRow = lastRow
End Function
I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)
Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from:
**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
to
**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.
Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()
Code:
Option Explicit
Sub CandCHyperlinx()
Dim cel As Range
Dim rng As Range
Dim adr As String
Dim delstring As String
'string to delete: CHANGE ME! (KEEP quotes!)
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\"
'get all cells as range
Set rng = ActiveSheet.UsedRange
'ignore non hyperlinked cells
On Error Resume Next
'check every cell
For Each cel In rng
'skip blank cells
If cel <> "" Then
'attempt to get hyperlink address
adr = cel.Hyperlinks(1).Address
'not blank? then correct it, is blank get next
If adr <> "" Then
'delete string from address
adr = Application.WorksheetFunction.Substitute(adr, delstring)
'put new address
cel.Hyperlinks(1).Address = adr
'reset for next pass
adr = ""
End If
End If
Next cel
End Sub
Is this even the right script? What am I doing wrong?
Try this:
Sub Macro1()
Const FIND_TXT As String = "C:\" 'etc
Const NEW_TXT As String = "Z:\" 'etc
Dim rng As Range, hl As Hyperlink
For Each rng In ActiveSheet.UsedRange.Cells
If rng.Hyperlinks.Count > 0 Then
Set hl = rng.Hyperlinks(1)
Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address
hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT)
hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT)
Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address
End If
Next rng
End Sub
I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong.
Sub FixLinks3()
Dim intStart As Integer
Dim intEnd As Integer
Dim strCol As String
Dim hLink As Hyperlink
intStart = 2
intEnd = 400
strCol = "B"
For i = intStart To intEnd
For Each hLink In ActiveSheet.Hyperlinks
hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
Next hLink
Next i
End Sub
Thanks for your help, Tim!
I have a macro which I run on many file. The goal is to define a source and copy the value inside my file. It works fine for 30 source files but I recently have one that makes my excel crash, no error message nothing.
Here the code:
'dimensioning of the variables
'range and workbook
Dim Target_Area As Range
Dim Account_Number, Account_Description, Debit, Credit As Range
Dim General_Balance As Workbook
Dim Transform_file As Workbook
Dim Source_Range As Range
'technical var
Dim LastCell As Range
Dim LastCellNumber As Long
Dim Array_Position As Integer
Dim Worksheet_general_balance As Long
Dim Links As Variant
Dim address As String
'var used to adapt to the different trial balance
Dim startline, account_column, description_column, debit_column, credit_column As Integer
Dim column_to_test As String
Dim Target_Column(0 To 3) As Integer
'setting the variables
address = "blabla"
startline = 5
account_column = 1
description_column = 2
debit_column = 3
credit_column = 4
column_to_test = "A"
Target_Column(0) = 1
Target_Column(1) = 4
Target_Column(2) = 5
Target_Column(3) = 6
Worksheet_general_balance = 1
Set Transform_file = ActiveWorkbook
Set General_Balance = Workbooks.Open(address)
With General_Balance.Worksheets(Worksheet_general_balance)
Set LastCell = .Cells(.Rows.Count, column_to_test).End(xlUp)
LastCellNumber = LastCell.Row
End With
MsgBox "General TB sheet name: " & General_Balance.Worksheets(Worksheet_general_balance).Name
'3. save the required range from the source file
General_Balance.Worksheets(Worksheet_general_balance).Activate
Set Account_Number = General_Balance.Worksheets(Worksheet_general_balance).Range(Cells(startline, account_column), Cells(LastCellNumber, account_column))
Set Account_Description = General_Balance.Worksheets(Worksheet_general_balance).Range(Cells(startline, description_column), Cells(LastCellNumber, description_column))
Set Debit = General_Balance.Worksheets(Worksheet_general_balance).Range(Cells(startline, debit_column), Cells(LastCellNumber, debit_column))
Set Credit = General_Balance.Worksheets(Worksheet_general_balance).Range(Cells(startline, credit_column), Cells(LastCellNumber, credit_column))
'copying the value to the file
Transform_file.Activate
Transform_file.Worksheets("general balance").Range(Cells(6, Target_Column(0)), Cells(LastCellNumber - startline + 6, Target_Column(0))).Value = Account_Number.Value
Transform_file.Worksheets("general balance").Range(Cells(6, Target_Column(1)), Cells(LastCellNumber - startline + 6, Target_Column(1))).Value = Account_Description.Value
'up to this point, everything works well
'THE FOLLOWING TWO LINES EITHER ONE OF THEM MAKE EXCEL CRASH
Transform_file.Worksheets("general balance").Range(Cells(6, Target_Column(2)), Cells(LastCellNumber - startline + 6, Target_Column(2))).Value = Debit.Value
Transform_file.Worksheets("general balance").Range(Cells(6, Target_Column(3)), Cells(LastCellNumber - startline + 6, Target_Column(3))).Value = Credit.Value
General_Balance.Close
If I replace the range name Debit or Credit by Account_Number for example, the macro will finish, so i guess it's not about the destination.
I tried to put this code:
For Each cell In Debit.Cells
MsgBox cell.Value
Next cell
Before the problematic lines, and it goes through all the cells without any problems.
I can't find any reason why it's not working... any idea ?
First I think you should add some On Error to your code, including a
MsgBox Err.Description,,Err.Number.
My first guess is that you are trying to write to an already open/locked file.
Sub test()
On Error GoTo Hell
'Do lots of things
'...
Adios:
Exit Sub
Hell:
MsgBox Err.Description, vbCritical, "Error " & Err.Number
Resume Adios
Resume
End Sub
With the above sample, when you get the message box, press Ctrl+Break, move the yellow dot from the resume Adios to the Resume line, then press F8. Now you are on the line that caused the error.
Another way is to start your Sub in debug mode, and press F8 until it crashes (and remember where that was !).
I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!
All right, this is my second attempt at a code, and the second VBA macro project I've been assigned to work on. I've been working to learn VBA as my first coding language for the last week and a half, so I apologize for silly mistakes. That said, straight to business. Here's what I put together for a word document macro:
Sub MacroToUpdateWordDocs()
'the following code gets and sets a open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim FinalrowName As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
FinalrowName = Finalrow + 1
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set auditmaster = CreateObject("excel.sheet")
'opening the document that is defined in the open file dialog
auditmaster.Application.Workbooks.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
auditmaster.Visible = False
'declare excel sheet
Dim wdoc As Document
'set active sheet
Set wdoc = Application.ActiveDocument
Dim i As Integer
Dim u As Integer
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
u = 1
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
'Sets up a loop to go through the Excel Audit file rows.
For i = 1 To auditmaster.ActiveSheet.Rows.Count
'Identifies ColumnAOldAddy and ColumnCNewAddy as columns A and C for each row i. Column A is the current hyperlink.address, C is the updated one.
ColumnAOldAddy = auditmaster.Cells(i, 1)
ColumnCNewAddy = auditmaster.Cells(i, 3)
'If C has a new hyperlink in it, then scan the hyperlinks in wdoc for a match to A, and replace it with C
If ColumnCNewAddy = Not Nothing Then
For u = 1 To doc.Hyperlinks.Count
'If the hyperlink matches.
If doc.Hyperlinks(u).Address = ColumnAOldAddy Then
'Change the links address.
doc.Hyperlinks(u).Address = ColumnCNewAddy
End If
'check the next hyperlink in wdoc
Next
End If
'makes sure the macro doesn't run on into infinity.
If i = Finalrow + 1 Then GoTo Donenow
'Cycles to the next row in the auditmaster workbook.
Next
Donenow:
'Now that we've gone through the auditmaster file, we close it.
auditmaster.ActiveSheet.Close SaveChanges:=wdDoNotSaveChanges
auditmaster.Quit SaveChanges:=wdDoNotSaveChanges
Set auditmaster = Nothing
End If
End Sub
So, this code is suppose to take a hyperlink audit file created by my first macro (The last bugs fixed and functioning wonderfully thanks to the Stack Overflow community!). The audit file has 3 columns and a row for each hyperlink it found in the target .docx: A = hyperlink address, B = Hyperlink displaytext, and C = the new Hyperlink address
When the code runs from the .docx file to be updated, it allows the user to choose the audit file. From there, it goes row by row to check if an updated hyperlink address has been written into the C column by the older audited address/display name, then searches the .docx file for the old hyperlink address and replaces it with the new hyperlink address. At that point, it finishes searching the document then moves on to the next row in the audit excel file.
My problem is that much of this code is copy/pasted out of code from an excel macro. I have been having a hell of a time figuring out how translate that code into something that identifies/references the word/excel documents appropriately. I'm hoping someone with more experience can take a peek at this macro and let me know where I've completely buggered up. It keeps giving me "Method or data member not found" errors all over the place currently, primarily concerning where I attempt to reference the audit excel file. I'm pretty sure that this is a relatively easy fix, but I don't have the vocabulary to figure out how to Google the answer!
Compiled OK, but not tested:
Sub MacroToUpdateWordDocs()
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim appXL As Object
Dim oWB As Object
Dim oSht As Object
Dim wdoc As Document
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
Dim i As Long
Dim h As Word.Hyperlink
Dim TheUser As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
Set appXL = CreateObject("excel.application")
appXL.Visible = True
SelectedFile = appXL.GetOpenFilename(Filter, , Caption)
appXL.Visible = False
If Trim(SelectedFile) = "" Then
appXL.Quit
Exit Sub
Else
Set oWB = appXL.Workbooks.Open(SelectedFile)
Set oSht = oWB.worksheets(1)
Finalrow = oSht.Cells(oSht.Rows.Count, 1).End(-4162).Row '-4162=xlUp
End If
Set wdoc = Application.ActiveDocument
For i = 1 To Finalrow
ColumnAOldAddy = oSht.Cells(i, 1).Value
ColumnCNewAddy = oSht.Cells(i, 3).Value
If ColumnCNewAddy <> ColumnAOldAddy Then
For Each h In wdoc.Hyperlinks
If h.Address = ColumnAOldAddy Then
h.Address = ColumnCNewAddy
End If
Next h
End If
Next i
oWB.Close False
appXL.Quit
End Sub