Name the Worksheet it's filename - excel

I have been searching for the answer to this question and have found some helpful hints but can't make it work within this code.
I'm copying three tabs and the workbook's name is in Cover!R11 but the other two tabs from that file need the filename as well with an extension (i.e. Filename, Cover, Filename Summary, Filename Estimate). If I reference the cell with the filename when I'm on the second sheet, how can I reference the previous sheet? That's why I thought it easier to use the Filename instead. I tried using: Sheets(SheetName1).Name = FilePath but I can't figure out how to trim it within this code. Can you help?
Here's the code:
Sub CopySheets()
Dim DialogBox As FileDialog
Dim FilePath As String
Dim SheetName As String
Set DialogBox = Application.FileDialog(msoFileDialogFilePicker)
DialogBox.Title = "Select Estimates to copy " & FileType
DialogBox.AllowMultiSelect = True
DialogBox.Filters.Clear
DialogBox.Show
If DialogBox.SelectedItems.Count = 1 Then
FilePath = DialogBox.SelectedItems(1)
End If
For i = 1 To DialogBox.SelectedItems.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = DialogBox.SelectedItems(i)
SheetName1 = "Cover"
SheetName2 = "Summary"
SheetName3 = "Estimate and Schedule "
Set closedBook = Workbooks.Open(FilePath)
closedBook.Sheets(SheetName1).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B2:Z97").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'The file name I want to use is in this field, but I can't reference it for the other tabs.
Sheets(SheetName1).Name = Range("R11")
closedBook.Sheets(SheetName2).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B5:K39").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'This line here didn't work to pull the previous sheet's value in R11
'Sheets(SheetName2).Name = prevname.Range("R11") & "Summary"
closedBook.Sheets(SheetName3).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("A3:M70").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Close SaveChanges:=False
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

If you want to use the value from 'Cover'!R11 later in the code store it in a variable.
'The file name I want to use is in this field, but I can't reference it for the other tabs.
Dim strFilename As String
' other code
strFilename = Sheets("Cover").Range("R11").Value
Sheets(SheetName1).Name = strFilename
' more code
Sheets(SheetName2).Name = strFilename & " Summary"
' even more code
Sheets(SheetName2).Name = strFilename & " Estimate"

Related

Copy Multiple files to another Workbook

I have the following code which should:
Open the selected files
Copy the three tabs indicated to another workbook
I thought this was working ok but then I realized that it's copying the first selected file the same amount of times as the number of selected files. So basically, it's not opening the other files and copying the tabs to the template. Can you help?
Sub CopySheets()
Dim DialogBox As FileDialog
Dim FilePath, SheetName As String
Set DialogBox = Application.FileDialog(msoFileDialogFilePicker)
DialogBox.Title = "Select Estimates to copy " & FileType
DialogBox.AllowMultiSelect = True
DialogBox.Filters.Clear
DialogBox.Show
If DialogBox.SelectedItems.Count = 1 Then
FilePath = DialogBox.SelectedItems(1)
End If
For i = 1 To DialogBox.SelectedItems.Count
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FilePath = DialogBox.SelectedItems(1)
SheetName1 = "Cover"
SheetName2 = "Summary"
SheetName3 = "Estimate and Schedule "
Set closedBook = Workbooks.Open(FilePath)
closedBook.Sheets(SheetName1).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B2:Z97").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(SheetName1).Name = i 'I would like this to be the File Name
closedBook.Sheets(SheetName2).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("B5:K39").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Sheets(SheetName3).Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Range("A3:M70").Select
Selection.Copy
Application.CutCopyMode = False
ActiveSheet.Unprotect Password:="zxc"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
closedBook.Close SaveChanges:=False
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Delete blank rows in new workbook

Sub vova()
Dim S_path As String
Dim S_name1 As String, S_nameW1 As String
S_path = "S:\Ãîëîâíèé Áàíê\Öåíòð óïðàâë³ííÿ ãîò³âêîþ\"
S_path = Trim(S_path) + Trim(Worksheets("1").Range("D6").Value) + ".xlsx"
Range("A1:N27").Select
Selection.Copy
Workbooks.Add
S_nameW1 = ActiveWorkbook.name
S_name1 = ActiveSheet.name
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Columns("A:A").ColumnWidth = 2
Columns("B:B").ColumnWidth = 10
Columns("C:C").ColumnWidth = 35
Columns("D:D").ColumnWidth = 13
Columns("M:M").ColumnWidth = 15
Columns("N:N").ColumnWidth = 15
Application.CutCopyMode = False
With S_name1
For i = .Range("A1048576").End(xlUp).Row To 9 Step -1
If .Cells(i, 2) = "" Then
.Rows(i & ":" & i).Delete
End If
Next
End With
ActiveWorkbook.SaveAs FileName:=S_path, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
End Sub
help solve the problem need macro to delete rows that are not field in range and create new workbook with field raws and columns. Getting this error (in column B there are drop down lists) and formulas in columns C,D,E
created workbook should look like this
If you want to store the name of the sheet to S_name1
Change
With S_name1
to
With WorkBooks(S_NameW1).WorkSheets(S_name1)
Volodymyr, you used a string variable with With keyword. You should use an object variable there.
...
Dim S_name1 as Worksheet
...
Set S_name1 = ActiveSheet
...

I have to copy some particular data in excel using macro

I have to copy data in excel from B5:L16 and paste it in another worksheet on C3:M14. I have the below code which copies the entire sheet. I am not able to identify the correct cell number.
Set wkbImportedWorkbook = ActiveWorkbook
Set wksImportedWorksheet = wkbImportedWorkbook.Sheets("Summary")
Set rngImportCopyRange = Range(wksImportedWorksheet.Cells(1, 1), Cells(5000, 1)).EntireRow
rngImportCopyRange.Copy wksMasterWorksheet.Cells(1, 1)
rngImportCopyRange.Copy
wksMasterWorksheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wkbMasterWorkbook.Activate
Application.DisplayAlerts = False
wkbImportedWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
wksMasterWorksheet.Activate
wksMasterWorksheet.Cells(1, 1).Select
Application.ScreenUpdating = True

VBA: Open files, calculate, paste values, repeat

I'm trying to write a macro that will Open files one by one in a provided directory, calculate all formulas, paste values over specific formulas, save, and exit, repeat process with next file. Here's what i have below:
Sub LoopPaloSnapshot()
Dim wb As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim FldrPicker As FileDialog
Dim FSO As New FileSystemObject
Dim MyFolder As Folder
Dim SubFolder As Folder
Dim MyFile2 As File
Application.ScreenUpdating = True
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
Set FSO = CreateObject("scripting.filesystemobject")
'In Case of Cancel
NextCode:
MyPath = MyPath
Set MyFolder = FSO.GetFolder(MyPath)
For Each SubFolder In MyFolder.SubFolders
For Each MyFile2 In SubFolder.Files
If FSO.GetExtensionName(MyFile2.Path) = "xlsx" Then
Set wb = Workbooks.Open(Filename:=MyFile2, UpdateLinks:=0)
Set ws = wb.Worksheets("Staffing Model")
Application.Run ("PALO.CALCSHEET")
Application.Calculate
Application.Run ("PALO.CALCSHEET")
Application.Calculate
Application.Calculation = xlCalculationManual
ws.Range("B1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F10:Q10").Value = ws.Range("F10:Q10").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F20:Q22").Value = ws.Range("F20:Q22").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F42:Q43").Value = ws.Range("F42:Q43").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F56:Q56").Value = ws.Range("F56:Q56").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F61:Q61").Value = ws.Range("F61:Q61").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
ws.Range("F66:Q66").Value = ws.Range("F66:Q66").Value
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
'Break Links
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
Dim xWs As Worksheet
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Staffing Model" Then
xWs.Delete
End If
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Loop
End If
Next
Next
MsgBox "Task Complete!"
ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
After running this, i open the newly saved files and there are #Value errors in place of the formulas im attempting to calculate and paste values over. I've tried walking through the macro line by line and it seems to be working properly for the most part, but for some reason the formulas are not calculating. if i open the file manually prior to running the macro, everything calculates perfectly so im wondering if something is causing these formulas to not calculate while the macro is running. any help would be appreciated.
EDIT: the formulas im copying and pasting values over are HLOOKUP's pulling from other tabs within the workbook, and PALO formulas pulling data directly from a JEDOX server. i've manually ran through the process im trying to automate without errors.
Instead of copying and pasting complex formulas, I'd suggest writing the formulas directly into the cells using this method:
Worksheets("Sheet1").Range("A1").Formula = "=$A$4+$A$10"
Pasted formulas can sometimes carry references to the original worksheet which causes chaos, whereas an explicitly set formula will not do that.
If you're really trying to take it offline then you could also use this method to set values as well.
Worksheets("Sheet1").Range("A1").Value = "100"

Pastespecial error on first run

This sub is set up to copy info over from one worksheet and paste the values into a new CSV workbook. I keep getting a runtime error on the pastespecial, however, it's only on the first click after opening the spreadsheet, if I click it again it works perfectly. And even though it gives me an error, when i click end it still pastes the values over.
Sub export_save()
Dim nrows As Integer
Dim norders As Integer
Dim i As String
Dim cell As Range
Dim fname As String
Dim WS As Worksheet
Dim WK As Workbook
Set WK = Workbooks.Add
Dim k As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
k = 2
i = "DO" 'plant to plant movement
'name new file
On Error GoTo canceled
fname = InputBox("Please name the new file, exlude any filename extensions.", "Export Data")
WK.SaveAs Filename:="S:\Active Customers\Teknor Apex\Feeds\Orders\" & fname, _
FileFormat:=xlCSV
MsgBox ("File saved to file path:S:\Active Customers\Teknor Apex\Feeds\dev\" & fname)
'copy info over
Workbooks("Teknor Template dev").Worksheets("REFORMATTED").Activate
nrows = Rows(Rows.Count).End(xlUp).Row
Workbooks("Teknor Template dev").Worksheets("REFORMATTED").Range("A3:AG" & nrows).copy
WK.Activate
Range("A1:AG" & nrows).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'remove parentheses
norders = Rows(Rows.Count).End(xlUp).Row
Range("AI2").FormulaR1C1 = "=MID(RC[-14],FIND(""("",RC[-14],1)+1,3)"
Range("AI2").AutoFill Destination:=Range("AI2:AI" & norders), Type:=xlFillDefault
Range("AI2:AI" & norders).copy
Range("U2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Columns("AI:AI").Delete Shift:=xlToLeft
'remove ship paratheses in DO orders
For Each cell In Range("B2:B" & norders)
If cell.Value = i Then
Range("AI" & k).FormulaR1C1 = "=MID(RC[-13],FIND("" ("",RC[-13],1)+1,3)"
Range("AI" & k).copy
Range("V" & k).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
k = k + 1
Next cell
'delete extra column used to remove paratheses
Columns("AI:AI").Delete Shift:=xlToLeft
WK.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
canceled:
End Sub
For clarity's sake here is a smaller version containing only the error, which is in the pastespecial line.
Workbooks("Teknor Template dev").Worksheets("REFORMATTED").Activate
nrows = Rows(Rows.Count).End(xlUp).Row
Workbooks("Teknor Template dev").Worksheets("REFORMATTED").Range("A3:AG" & nrows).copy
WK.Activate
Range("A1:AG" & nrows).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Change:
Range("A1:AG" & nrows).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
To:
Range("A1:AG" & nrows).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Your code is missing Paste:=

Resources