My Sheet Name is Eg: PMCC 1 and I have Content in sheet is PMCC#01.
I would like to Convert Sheet Name into PMCC#01 with replace function.
I tried this code
temp = ws.Name
newtemp = Replace(temp,"","#0")
As result, I only get 1.
Won't you just need:
ws.Name = Replace(ws.Name, " ", "#0")
Main difference is " " instead of ""
Try:
Option Explicit
Sub test()
Dim strName As String
Dim ws As Worksheet
With ThisWorkbook
For Each ws In .Worksheets '<- Loop all sheets
With ws
strName = .Range("A1") '<- Let us assume that the new name appears in all sheets at range A1
.Name = strName '<- Change sheet name
End With
Next ws
End With
End Sub
The main issue is: you have created a variable, you have entered a value in it, coming from the sheet name, and you believe that modifying the value of that variable will automatically modify your sheet name.
This is not the way variables work: you specifically need to put your variable's value into the sheet name, something like:
temp = ws.Name
newtemp = Replacement_function(temp, ...) // not sure to use `Replace()` or `Substitute()`
ws.Name = newtemp
In case the numeric element of your worksheet name can be 10 or higher, you might want to do this:
temp = Split(ws_Name, " ")
newtemp = temp(0) & "#" & Format(temp(1), "00")
That way, PMCC 1 becomes PMCC#01 but PMCC 13 would become PMCC#13, not PMCC#013
Related
I would like to save file in a "CONSOLIDATE FOLDER". But the file path should depend on staff working number ID (00639) where they input it in the "TEMPLATE" worksheet cell "N3". And in case staff forgot to input their working ID, there'll be a pop up box telling them to fill in their ID.
Any help really appreciated.
Sub MergeFile ()
Dim WB As Workbook
Dim WS as Worksheet
Dim FileName as String
Dim FilePath as String
Set WB = Workbook.Add
FilePath = "C:\Users\KGA00639\Desktop\CONSOLIDATE FOLDER"
FileName = ThisWorkbook.Worksheets("TEMPLATE").Range("L15").Value
For Each WS in ThisWorkbook.Worksheets
If WS.Name <> "TEMPLATE" Then
WS.Copy before:=WB.Sheets(1)
End if
If FileName = "" Then
FileName = InputBox ("You did not name the workbook" & vbCrLf & _
"Please write the name and press OK.:,"Setting the workbook name")
If FileName = "" Then Exit sub
ThisWorkbook.Worksheets("TEMPLATE").Range("L15").Value = FileName
End If
Next
ActiveWorkbook.SaveAs FileName:=FilePath & "\" & FileName
MsgBox ("Done"!)
ActiveWorkbook.Close
End Sub
This solution should come rather close to what you want. Please take a look.
Sub MergeFile()
' 056
Dim Wb As Workbook
Dim Ws As Worksheet
Dim FileName As String
Dim FilePath As String
Dim UserID As String
With ThisWorkbook.Worksheets("TEMPLATE")
UserID = .Cells(1, "A").Value ' change address to suit
FileName = .Range("L15").Value
If Left(UserID, 2) <> "ID" Then
MsgBox "You must enter your valid user ID in" & vbCr & _
"cell A1 of the 'Template' tab." & vbCr & _
"This program will now be terminated.", _
vbInformation, "Incomplete preparation"
.Activate
.Cells(1, "A").Select ' change to match above
Exit Sub
End If
End With
Application.ScreenUpdating = False
' use the UserID variable in whichever way you wish
FilePath = Environ("UserProfile") & "\" & UserID & "\Desktop\CONSOLIDATE FOLDER"
Set Wb = Workbooks.Add
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "TEMPLATE" Then
Ws.Copy Before:=Wb.Sheets(1)
End If
Next Ws
Wb.SaveAs FilePath & FileName, xlOpenXMLWorkbook
Application.ScreenUpdating = True
End Sub
You didn't specify where on the 'Template' tab the user ID would be found. The above code looks for it in cell A1. That cell is mentioned in 3 locations in the code (once in the message text). Please modify the code to match your facts.
You also didn't say where the UserID should appear in the FilePath. I placed it before the Desktop. I'm sure you will know how to amend that bit of code to suit you better.
When saving the workbook my code specifies an xlsx format. If this isn't what you want change the file format constant in the SaveAs line. I didn't think it a good idea to specify the extension in the 'Template'. You may like to move it to the code.
Finally, you didn't specify the next step after creation of the new workbook. So the code ends in the middle of nowhere. Excel made the new workbook the active one but you may like to close it, or ThisWorkbook, and determine what to do with the blank worksheet(s) still contained in the new book. There are a lot of lose ends still to tidy up. Good luck!
I have two Workbooks. I need to take a String from WB1 (I iterate through Column C in WB1, not every cell contains a String, but when a cell contains a string this is the one I want to copy), find it in WB2 and replace it with another String from WB1 (in the same row, but column A). Here is what I have so far:
' Checks if a given File is already open
Public Function FileInUse(sFileName) As Boolean
On Error Resume Next
Open sFileName For Binary Access Read Lock Read As #1
Close #1
FileInUse = IIf(Err.Number > 0, True, False)
On Error GoTo 0
End Function
Sub copyPaste()
Dim destWB As Workbook
Dim destSH As Worksheet
Dim fileName As String
Dim curCell As Range
Dim oldName As Range
Dim result As Range
' turn off screen refresh, recalculate formula to speed up sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' For i = 2 To Rows.Count
For i = 2 To 5
fileName = "C:\Users...\" & Workbooks("Ressources calculation.xlsm").Worksheets("Tests costs").Cells(i, 2)
If Not FileInUse(fileName) Then
Set destWB = Workbooks.Open(fileName)
Set destSH = destWB.Sheets("Qualification Matrix")
destSH.Activate
End If
Set curCell = Workbooks("Ressources calculation.xlsm").Sheets("Tests costs").Cells(i, 3)
Set oldName = Workbooks("Ressources calculation.xlsm").Sheets("Tests costs").Cells(i, 1)
If Not IsEmpty(curCell) Then
curCell.Copy
Set result = destWB.Sheets("Qualification Matrix").Cells.Find(What:=oldName.Text, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, MatchByte:=True)
If Not result Is Nothing Then
result.PasteSpecial
End If
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have added a MsgBox in the "If Not result" clause which never triggers, so I guess it is not finding the cell. It seems to extract the strings I need to use (in curCell and oldName) fine though (checked also with MsgBox). The cells in which it should search and replace are merged cells, if that makes a difference. I also tried out different values for Cells.Find (leaving all optional parameters, tried all possibilities for lookIn and lookat, MatchByte, tried oldName.Value instead).
This is the first time I'm doing something with Excel Macros/VBA, the last few hours were spend with a lot of trial and error without any result. So I'm sure what I have so far is far from optimal, but I hope that someone can help me with it.
Edit: I narrowed it down a bit. I now activate destSH right before Cells.Find and tried just using a hardcoded example String as a parameter, which works. So I guess the problem is not the find statement but how I try to extract the information I'm looking for with find.
Edit2: As requested, here is a short example walkthrough:
I have a Workbook called "Ressources calculation.xlsm" with three Columns: Current name, File name, New name. Row 4 looks like this:
Misspelledd [File name].xlsx Misspelled
Not every Cell in Column C is filled out. What I'm trying to do is: Iterate through every cell in Column C, if it is not empty copy the string which is in the same row but in Column A, look for it in the file which is noted in Column B and replace it with the right name written under Column C.
Here is a picture of the cell in the destination Workbook which should be found and the text replaced as explained above. It is a merged cell, stretching over rows 2-5.
Edit 3: I finally found out what the problem was. There were "invisible" line breaks at the end of some cells (not really invisible, but you don't easily see them since there are no characters coming after). If this is not the case, the code works.
Try something like this (added some debug.print for troubleshooting)
Sub copyPaste()
Dim destWB As Workbook
Dim destSH As Worksheet
Dim fileName As String
Dim curName, oldName
Dim result As Range
Dim wbRes As Workbook, wsTests As Worksheet
Set wbRes = Workbooks("Ressources calculation.xlsm") 'ThisWorkbook ?
Set wsTests = wbRes.Worksheets("Tests costs")
For i = 2 To 5
fileName = "C:\Users...\" & wsTests.Cells(i, 2)
If Not FileInUse(fileName) Then
Set destWB = Workbooks.Open(fileName)
Set destSH = destWB.Sheets("Qualification Matrix")
curName = Trim(wsTests.Cells(i, 3).Value) '<< always worth adding Trim()...
oldName = Trim(wsTests.Cells(i, 1).Value)
If Len(curName) > 0 Then
Debug.Print "Looking for: '" & oldName & _
"' on sheet '" & destSH.Name & "' in " & _
destWB.FullName
Set result = destSH.UsedRange.Find(What:=oldName, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not result Is Nothing Then
Debug.Print "...found"
result.Value = curName
Else
Debug.Print "... not found"
End If
End If
End If 'file not in use
Next i
End Sub
I'm pretty new to VBA and love to challenge myself, but am at a loss on this project however.
I have a workbook that has quite a few tabs used for various calculations and summations. The "PDP Base" main tab takes all "PDP BaseX" tabs and adds all values for the same cell across all "PDP BaseX" tabs into the main one. This is easy to handle manually when there are only 5 or so "PDP BaseX" tabs, but if there are potentially many tabs to add together (10+), combing through each is a pain. This is made worse if there are multiple cases to add formulas to (PNP;PBP;PUD;PBL - with each having a Base and Sens modifier).
Each new "PDP BaseX" tab is copy pasted from a template ran by other code (not yet finished) with a new "X+1" value, and so I don't want to just copy paste a formula adding the new tab into the main tab.
The end result will have code for all the main tabs of each category, but if I can get one main tab to do what I want, I can go from there.
Below is some code that I feel is close, but it loops to infinity somewhere in there and won't move pass initial cell B29 (getting overflow into PDP Base B29 when result should be lets say 10 for example; PDP Base1 B29 = 2; PDP Base2 B29 = 6; PDP Base3 B29 = 4)
Private Sub Worksheet_Calculate()
Dim ws As Worksheet, mainws As Worksheet
Dim rng As Range, mainrng As Range
Dim x As Single, y As Single
Dim tVar As Double
Set mainws = ActiveWorkbook.Worksheets("PDP Base")
With mainws
For y = 2 To 4
For x = 29 To 43
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "PDP Base*" And ws.CodeName <> "PDPBase" Then
'the main tab has a codename assigned to it to not add itself
With ws
With .Range(Cells(x, y))
tVar = tVar + .Range(Cells(x, y)).Value
End With
End With
End If
Next ws
Set mainrng = Cells(x, y)
mainrng.Value = tVar
tVar = 0
Next x
Next y
End With
End Sub
Would someone be able to shed some insight into this? Thank you!
Untested but should do what you want:
Private Sub Worksheet_Calculate()
Const MAIN_WS_NAME As String = "PDP Base" 'use a constant for fixed values
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim x As Long, y As Long 'Long not Single
Dim tVar As Double
Set wb = ActiveWorkbook
Set mainws = wb.Worksheets(MAIN_WS_NAME)
For y = 2 To 4
For x = 29 To 43
tVar = 0
For Each ws In wb.Worksheets
If ws.Name Like MAIN_WS_NAME & "*" And ws.Name <> MAIN_WS_NAME Then
tVar = tVar + ws.Cells(x, y).Value
End If
Next ws
mainws.Cells(x, y).Value = tVar
Next x
Next y
End Sub
Its been a bit since I posted the original question, but I've gotten much further since then and just wanted to post my progress for others to use incase they need something similar.
There is still a lot of cleaning that could be done, and its not finished, but the basic idea works really really well. The code takes several codenamed (not tab names; allows users to change the tab name to something different) main sheets and loops through each, adding formulas that dynamically add cells from similarly named subsheets into the main sheet across multiple blocks of cells.
Also wanted to thank the original answer again provided by Tim Williams as that helped me tremendously to get going in the right direction and is the foundation to the code below.
Use at your own risk. I hear CodeNames and using VBProject type of codes can give you a bad day if they break.
Main Code Below
Public Sub Sheet_Initilization()
Dim ws As Worksheet, mainws As Worksheet, wb As Workbook
Dim codename As String
Dim mainwsname As String
Set wb = ActiveWorkbook
'block code to run code smoother
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'PLACEHOLDER FOR LATER USE CaseNames = Array("PDPBase", "PDPSens", "PBPBase", "PBPSens", "PNPBase", "PNPSens", "PUDBase", "PUDSens")
CaseNames = Array("PDPBase", "PBPBase", "PNPBase", "PUDBase") 'main 4 cases, more to come
For Each c In CaseNames 'cycle through each "Main" case sheet
codename = c
Set mainws = wb.Sheets(CN(wb, codename)) 'calls function to retrieve code name of the main case sheet
'allows users to change main case tab names without messing up the codes
'must change security settings to use, looking into alternatives
mainwsname = mainws.Name 'probably could do without with some optimization
For Each b In Range("InputAdditionCells").Cells 'uses named range of multiple blocks of cells, B29:D34 M29:O43 I53:J68 for example
'cycles through each cell in every block
mainws.Range(b.Address).Formula = "=" 'initial formula
For Each ws In wb.Worksheets 'cycles through each sheet
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then 'finds similarily named sub sheets (PDP Base 1, PDP Base 2...etc)
', but won't use the main sheet (PDP Base)
If b.Address Like "$Y*" Then 'special column to use different offset formula
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Offset(0, 4).Address
Else
mainws.Range(b.Address).Formula = mainws.Range(b.Address).Formula & "+'" & ws.Name & "'!" & b.Address
End If
End If
Next ws
Next b
For Each d In Range("InputWeightedCells").Cells 'same idea as before, different main formula (weighted average)
mainws.Range(d.Address).Formula = "="
For Each ws In wb.Worksheets
If ws.Name Like mainwsname & "*" And ws.Name <> mainwsname Then
If d.Address Like "*$68" Then 'special row to use different offset formula
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-21, 23).Address & ")"
Else
mainws.Range(d.Address).Formula = mainws.Range(d.Address).Formula & "+('" & ws.Name & "'!" & d.Address _
& "*'" & ws.Name & "'!" & d.Offset(-24, 23).Address & ")"
End If
End If
Next ws
Next d
MsgBox (mainwsname) 'DELETE; makes sure code is running properly/codebreak without using the break feature
Next c
'reactivate original block code
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub 'cool beans
Function that's called (need to change the Macro settings in the trust center settings from excel options to run). Once again use at your own risk.
Function CN(wb As Workbook, codename As String) As String
CN = wb.VBProject.VBComponents(codename).Properties("Name").Value
End Function
Looking to add a second function with the click of the command button in Excel with VBA code - first function populates data from worksheet one (an order form) to a database log in worksheet two. Looking for the second function to be carried out to be an auto-save with cell value from the order form. Thank you!
Private Sub CommandButton1_Click()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
Set OFrm = Worksheets("Order Form 1")
Set DB = Worksheets("Database")
OrderDate = OFrm.Range("B3")
PONumber = OFrm.Range("D3")
Vendor = OFrm.Range("B7")
ShipTo = OFrm.Range("D7")
LastSKURow = OFrm.Cells(OFrm.Rows.Count, "F").End(xlUp).Row
For R = 3 To LastSKURow
SKU = OFrm.Range("F" & R).Value
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Value = OrderDate
DB.Range("B" & NextDBRow).Value = PONumber
DB.Range("C" & NextDBRow).Value = Vendor
DB.Range("D" & NextDBRow).Value = ShipTo
DB.Range("E" & NextDBRow).Value = SKU
Next R
Application.ScreenUpdating = False
Dim Path As String
Dim filename As String
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,
Path = "C:\PDF\"
filename = OFrm.Range("D3")
OFrm.SaveAs filename:=Path & filename & ".pdf", FileFormat:=xlPDF
OpenAfterPublish:=False
Application.ScreenUpdating = True
End Sub
by auto-save do you mean that it saves the excel workbook? if so you could add something like this...
Application.ActiveWorkbook.Save
If this is not what you are looking for please let me know...
Sorry it took a few days, I've been quite busy.
Based on your previous comment this subroutine that I wrote should resolve your problem. I chose to save the file as a pdf with the assumption that you've set a print area to your form. I chose a pdf because you stated it was an order form and the assumption is that the form will not be edited later. I opted to it because it was a form and there may be some calculated fields attached to another sheet which would not work if you detached the worksheet. If however you decide that you just want a copy of the worksheet I've included the code for it as well. All you need to do is fill in the areas with the comments and attach this function to a command button :). Please let me know if you would like additional information about how to do this.
For the pdf function you can see the information here: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/workbook-exportasfixedformat-method-excel
For the Save As information you can see the information here: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/worksheet-saveas-method-excel
Public Sub savefile()
Dim wb As Workbook
Dim ws As Worksheet
Dim rngfilename As Range
Dim strSavePath As String
'assumptions:
'you are saving the file to a fixed location and the name of the file within the range is continually changing
'you have set the print areas
Set wb = Application.ActiveWorkbook
Set ws = wb.ActiveSheet
Set rngfilename = ws.Range("A1") 'the range that contains your filename
strSavePath = "C:/" 'the location that you would like to save your file
'ensure that there is a value within the filename field declared above
If rngfilename.Value = "" Or Len(rngfilename) = 0 Then
MsgBox "You have not entered a filename"
Exit Sub
End If
'if you do not have print areas set ignore print areas to true in the function bellow
ws.ExportAsFixedFormat xlTypePDF, strSavePath & rngfilename.Value, xlQualityStandard
'for the save as function
'ws.SaveAs strSavePathe & rngfilename.Value
End Sub
I am trying to copy the string values(column titles) from another workbook in row 4 as captions for checkboxes in the workbook where I am running the code. This is what I have so far and it is not working because it is showing the error message "Subscript out of range, run time error 9" Here is what I have. After the error message pops up the line marked below is highlighted. Can anybody help me please. Thank you very much.
Function CallFunction(SheetName As Variant) As Long
Dim text As String
Dim titles(200) As String ' Dim titles(200) As String ' Array
Dim nTitles As Integer
Dim wks As Worksheet
Dim myCaption As String
PathName = Range("F22").Value
Filename = Range("F23").Value
TabName = Range("F24").Value
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=PathName & "\" & Filename
ActiveSheet.Name = TabName
Set wks = Workbooks("Filename").Worksheets(SheetName).Activate ' <= Highlights this line ****
For i = 1 To 199
If Trim(wks.Cells(4, i).Value) = "" Then
nTitles = i - 1
Exit For
End If
titles(i - 1) = wks.Cells(4, i).Value
Next
i = 1
For Each cell In Range(Sheets("Sheet1").Cells(4, 1), Sheets("Sheet1").Cells(4, 1 + nTitles))
myCaption = Sheets("Sheet1").Cells(4, i).Value
With Sheets("Sheet1").checkBoxes.Add(cell.Left, _
cell.Top, cell.Width, cell.Height)
.Interior.ColorIndex = 12
.Caption = myCaption
.Characters.text = myCaption
.Border.Weight = xlThin
.Name = myCaption
End With
i = i + 1
Next
End Function
Subscript out-of-range typically indicates that a specified Worksheet does not exist in the workbooks Worksheets collection.
Otherwise, are you sure that the workbook specified by FileName is already open? If not, that will raise the same error.
Ensure that A) the file is already open (or use the Workbooks.Open method to open it), and B) ensure that such a worksheet already exists (if not, you will need to create it before you can reference it by name).
Update
You have Workbooks("FileName") where "Filename" is a string literal. Try changing it to simply Filename (without the quotation marks) (this seems like the OBVIOUS error).
Also worth checking:
I also observe this line:
ActiveSheet.Name = TabName
If the sheet named by SheetName is active when the workbook opens, then that line will effectively rename it, so you will not be able to refer to it by SheetName, but instead you would have to refer to it by Worksheets(TabName). ALternatively, flip the two lines so that you activate prior to renaming:
Set wks = Workbooks(Filename).Worksheets(SheetName).Activate
ActiveSheet.Name = TabName
For further reading: avoid using Activate/Select methods, they are confusing and make your code harder to interpret and maintain:
How to avoid using Select in Excel VBA macros
If that is the case, then you could do simply:
Workbooks(Filename).Worksheets(SheetName).Name = TabName