How can I copy only the range of cells from A1 to J47 to a new worksheet, and not the whole sheet? Thank you
Sub Salva()
Dim X As String
X = "Foglio salvato n° " & Range("G3").Value
Sheets(1).Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\wc074\Documents\archivi\" & X & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
End Sub
Please, try the next code:
Sub Salva()
Dim X As String, sh As Worksheet, newWb As Workbook, rng As Range
Set sh = ActiveSheet
X = "Foglio salvato n° " & sh.Range("G3").value
Set rng = sh.Range("A1:J47")
Set newWb = Workbooks.Add
rng.Copy newWb.Sheets(1).Range("A1")
newWb.Sheets(1).UsedRange.EntireColumn.AutoFit
newWb.saveas FileName:="C:\Users\wc074\Documents\archivi\" & X & ".xls", FileFormat:=xlExcel8 'Excel 97-2003 Workbook
newWb.Close False
End Sub
Related
I have a userform with 2 checkboxes, when the user clicks on the send button it should copy the sheet 1 from currentWorkbook to a new workbook. If the user clicks in one of checkboxes (1 or 2) it works but if I clicks on the 2 checkboxes at the same time it doesn't work.
My goal is if the user clicks on the 2 checkboxes, it copies the sheet 1 from currentWorkbook to 2 new workbooks.
Any help is highly appreciated.
Private Sub CommandButton1_Click()
Dim theNewWorkbook As Workbook
Dim currentWorkbook As Workbook
Dim sFileSaveName As Variant
Dim industry As String
Dim dttoday As String
Set currentWorkbook = Workbooks("blabla" & ".xlsm")
Set theNewWorkbook = Workbooks.Add
currentWorkbook.Sheets("Sheet1").Activate
If one= True Then
currentWorkbook.Worksheets("Sheet1").Copy before:=theNewWorkbook.Sheets(1)
With ActiveSheet
.ListObjects(1).Name = "one"
End With
ActiveSheet.ListObjects("one").Range.AutoFilter Field:=1, Criteria1:= _
Array("bla", "ble", "bli", "blo"), _
Operator:=xlFilterValues
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveSheet.ShowAllData
'Save File
industry = "one "
dttoday = VBA.format(Now(), "ddmmyyyy")
saveLocation = "C:\blabla" & industry & dttoday & ".xlsx"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
If sFileSaveName <> "False" Then ActiveWorkbook.SaveAs sFileSaveName
theNewWorkbook.Close
End If
If two = True Then
currentWorkbook.Worksheets("Sheet1").Copy before:=theNewWorkbook.Sheets(1)
With ActiveSheet
.ListObjects(1).Name = "two"
End With
ActiveSheet.ListObjects("two").Range.AutoFilter Field:=1, Criteria1:= _
Array("bla", "ble", "bli"), _
Operator:=xlFilterValues
Rows("2:2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveSheet.ShowAllData
'Save File
industry = "two "
dttoday = VBA.format(Now(), "ddmmyyyy")
saveLocation = "C:\blabla_" & industry & dttoday & ".xlsx"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
If sFileSaveName <> "False" Then ActiveWorkbook.SaveAs sFileSaveName
End If
Unload Me
End Sub
This code should do the following:
If checkbox one is checked create a new workbook with a copy of Sheet1 from the current workbook in it and name the table on the copied sheet 'one'.
If checkbox two is checked create a new workbook with a copy Sheet1 from the current workbook in it and name the table on the copied sheet 'two'.
Do both if both checkboxes are checked.
Option Explicit
Private Sub CommandButton1_Click()
Dim theNewWorkbook As Workbook
Dim currentWorkbook As Workbook
Dim sFileSaveName As Variant
Dim industry As String
Dim dttoday As String
Set currentWorkbook = Workbooks("blabla" & ".xlsm")
If one = True Then
currentWorkbook.Worksheets("Sheet1").Copy
Set theNewWorkbook = ActiveWorkbook
With theNewWorkbook
With .ActiveSheet
.ListObjects(1).Name = "one"
.ListObjects("one").Range.AutoFilter Field:=1, Criteria1:= _
Array("bla", "ble", "bli"), _
Operator:=xlFilterValues
.Range(.Rows("2:2"), .Rows("2:2").End(xlDown)).Delete
.ShowAllData
End With
'Save File
industry = "one "
dttoday = Format(Now(), "ddmmyyyy")
saveLocation = "C:\blabla" & industry & dttoday & ".xlsx"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
If sFileSaveName <> "False" Then
.SaveAs sFileSaveName
End If
.Close
End With
End If
If two = True Then
currentWorkbook.Worksheets("Sheet1").Copy
Set theNewWorkbook = ActiveWorkbook
With theNewWorkbook
With .ActiveSheet
.ListObjects(1).Name = "two"
.ListObjects("two").Range.AutoFilter Field:=1, Criteria1:= _
Array("bla", "ble", "bli", "blo"), _
Operator:=xlFilterValues
.Range(.Rows("2:2"), .Rows("2:2").End(xlDown)).Delete
.ShowAllData
End With
'Save File
industry = "two "
dttoday = Format(Now(), "ddmmyyyy")
saveLocation = "C:\blabla" & industry & dttoday & ".xlsx"
sFileSaveName = Application.GetSaveAsFilename(InitialFileName:=saveLocation, fileFilter:="Excel Files (*.xlsx), *.xlsx")
If sFileSaveName <> "False" Then
.SaveAs sFileSaveName
End If
.Close
End With
End If
Unload Me
End Sub
I am not familiar with VBA so please forgive the simplicity of this question. I have a recorded macro which selects, opens then saves a file from a hyperlink in one of my columns. I just want to make a loop to repeat this macro down all of the rows in the worksheet which have data in them. Below is the code for the recorded macro, thank you all for your assistance.
Sub Extract()
'
'Extract Macro
'
'
Range("D2").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:= _
"https://channele.corp.etradegrp.com/communities/teams02/performance-monitoring/TPEF%20Library/A2Consulting_Tech_5650_VSAF.xlsm"
ActiveWindow.Visible = False
Windows("A2Consulting_Tech_5650_VSAF.xlsm").Visible = True
ChDir "O:\Procurement Planning\QA"
ActiveWorkbook.SaveAs Filename:= _
"O:\Procurement Planning\QA\Copy of A2Consulting_Tech_5650_VSAF.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
End Sub
Something like this might work already:
Sub Extract()
Dim RngTarget As Range
Dim StrFileName As String
Set RngTarget = Range("D2")
Do Until RngTarget.Value = ""
RngTarget.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:=RngTarget.Value
StrFileName = Split(RngTarget.Value, "/")(UBound(Split(RngTarget.Value, "/")))
Windows(StrFileName).Visible = True
Workbooks(StrFileName).SaveAs Filename:="O:\Procurement Planning\QA\Copy of " & Split(StrFileName, ".")(0) & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False
Workbooks(StrFileName).Close
Set RngTarget = RngTarget.Offset(1, 0)
Loop
End Sub
So i found this code online and was able to edit it to do what i want EXCEPT save as a PDF it currently set to only show me a print preview. Can someone explain how to edit this to save as a PDF with the File name being what ends up appearing in cell "A2"
Sub testme()
Dim TempWks As Worksheet
Dim wks As Worksheet
Dim myRng As Range
Dim myCell As Range
'change to match your worksheet name
Set wks = Worksheets("Sheet3")
Set TempWks = Worksheets.Add
wks.AutoFilterMode = False 'remove the arrows
'assumes headers only in row 1
wks.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), Unique:=True
With TempWks
Set myRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With wks
For Each myCell In myRng.Cells
.UsedRange.AutoFilter Field:=1, Criteria1:=myCell.Value
Dim MyFileName As Variant
Dim MyfilePath As Variant
Dim rng As Range
Set wks = Worksheets("Sheet3")
Set rng = wks.Cells(2, 1)
MyfilePath = "C:\Users\mmunoz\Desktop\Teresa" 'this is whatever location you wish to save in
MyFileName = MyfilePath & "\" & rng.Value & ".pdf" 'You can do the below in just a couple of lines, but this is way more effective and stops issues later on
ChDir _
MyfilePath ' hold your save location
wks.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'did you want to open the file after saving?
Next myCell
End With
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
End Sub
I have a bunch of data that I need to filter to show only a client's lines of data and save that as a PDF to send to the client.
Thanks,
This is the gist of what you want. I've added comments to explain
Dim MyFileName As Variant
Dim MyfilePath As Variant
Dim rng As Range
Set rng = wks.Cells(2, 1)
MyfilePath = "N:\Desktop" 'this is whatever location you wish to save in
MyFileName = MyfilePath & "\" & rng.Value & ".pdf" 'You can do the below in just a couple of lines, but this is way more effective and stops issues later on
ChDir _
MyfilePath ' hold your save location
wks.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True 'did you want to open the file after saving?
Option Explicit
Sub testme()
Dim TempWks As Worksheet
Dim wks As Worksheet
Dim myRng As Range
Dim myCell As Range
'change to match your worksheet name
Set wks = Worksheets("Sheet3")
Set TempWks = Worksheets.Add
wks.AutoFilterMode = False 'remove the arrows
'assumes headers only in row 1
wks.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), Unique:=True
With TempWks
Set myRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With wks
For Each myCell In myRng.Cells
.UsedRange.AutoFilter Field:=1, Criteria1:=myCell.Value
Dim MyFileName As Variant
Dim MyfilePath As Variant
Dim rng As Range
Set rng = wks.Cells(2, 1)
MyfilePath = "C:\Users\mmunoz\Desktop\Teresa" 'File Location
MyFileName = MyfilePath & "\" & myCell.Value & ".pdf" 'File Name
ChDir _
MyfilePath
wks.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
MyFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next myCell
End With
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
End Sub
I have a spreadsheet with lots of tabs. I am wanting to copy each tab into its own file which I can do with the code below.
My problem is adding an instruction sheet aswell to each of the new workbooks. I have an instruction sheet in the original workbook.
Your help would be appreciated.
Sub Splitbook()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & " SP Signoff.xlsx"
ActiveWorkbook.Close savechanges:=False
Next sht
End Sub
Sub Splitbook()
Dim wkb As Workbook
Dim wks As Worksheet, sht As Worksheet
Dim strPath As String
Set wkb = ThisWorkbook
Set wks = Sheets("Instructions")
strPath = wkb.Path
For Each sht In wkb.Sheets
If sht.Name <> "Instructions" Then
sht.Copy
With ActiveSheet
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues
.Cells.PasteSpecial Paste:=xlPasteFormats
End With
wks.Copy Before:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & " SP Signoff.xlsx"
ActiveWorkbook.Close savechanges:=False
End If
Next
End Sub
I have one large Excel workbook with multiple worksheets containing pivot tables linked to a big PowerPivot source. I want to save each worksheet separately into workbooks, only as values.
I have managed to do this on a workbook without pivot tables. But I get the following message with this project. I don't want to copy the embedded data for each save as it is crazy slow. Any hints or help?
Option Explicit
Sub JhSeparateSave()
Dim ws As Worksheet
Dim NewName As String
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
With Application
.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
MsgBox ("Copy step 1")
ws.Copy
With ActiveWorkbook.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewName & "-" & ws.Name
ActiveWorkbook.Close
MsgBox ("Saved sheet: " & ws.Name)
End If
Next ws
End With
End Sub
See this example (TESTED AND TRIED).
Option Explicit
Sub JhSeparateSave()
Dim wbTemp As Workbook
Dim ws As Worksheet
Dim NewName As String
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
'~~> Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
With Application
.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
MsgBox ("Copy step 1")
ws.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close savechanges:=False
Set wbTemp = Workbooks.Open(ThisWorkbook.Path & "\" & NewName & ".csv")
wbTemp.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & "-" & ws.Name, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wbTemp.Close savechanges:=False
Kill ThisWorkbook.Path & "\" & NewName & ".csv"
MsgBox ("Saved sheet: " & ws.Name)
End If
Next ws
End With
End Sub
what i eventually used:
Option Explicit
Sub Copier()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim NewName As String
Dim wsOriginalName As String
'On Error GoTo Errorcatch
If MsgBox("1. Copy to new sheet. 2. Change to values. 3. Move to new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
' Input box to name new file
NewName = InputBox("Please Specify the month name of your new workbook", "New Copy")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
'iterate through all worksheets
For Each ws In ThisWorkbook.Worksheets
'ignore hidden worksheets
If ws.Visible = xlSheetVisible Then
'copy sheet within original workbook
wsOriginalName = ws.Name
ws.Copy After:=Sheets("FAQ")
'switch to copied sheet
Set wsNew = ActiveSheet
'convert to values and format
With wsNew.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
.Cells(1, 1).Select
End With
'save into new workbook
wsNew.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "MIS-FY2013-" & NewName & "-" & wsOriginalName
ActiveWorkbook.Close
'MsgBox ("going to try to delete: " & wsNew.Name)
'delete copied sheet
wsNew.Delete
End If
Next ws
End With
End Sub