Getting control variable in use for this, I guess because of "ws", can someone help how to fix? Thanks
Sub CreateNewWBS()
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String
Set wbThis = ThisWorkbook
For Each ws In wbThis.Worksheets
strFilename = wbThis.Path & "/" & ws.Name
ws.Copy
Set wbNew = ActiveWorkbook
For Each ws In wbNew.Worksheets
ws.Cells.Copy
ws.Cells.PasteSpecial xlPasteValues
wbNew.SaveAs strFilename
wbNew.Close
Next ws
End Sub
Used ws2 and fixed Next statements, works now:
Sub CreateNewWBS()
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim strFilename As String
Set wbThis = ThisWorkbook
For Each ws In wbThis.Worksheets
strFilename = wbThis.Path & "/" & ws.Name
ws.Copy
Set wbNew = ActiveWorkbook
For Each ws2 In wbNew.Worksheets
ws2.Cells.Copy
ws2.Cells.PasteSpecial xlPasteValues
Next
wbNew.SaveAs strFilename
wbNew.Close
Next ws
End Sub
Here is a simplified version of your code:
Sub CreateNewWBs()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Copy
With ActiveWorkbook
.Worksheets(1).UsedRange.Value = .Worksheets(1).UsedRange.Value
.SaveAs ThisWorkbook.Path & "/" & ws.Name
.Close
End With
Next ws
End Sub
I have removed the second For loop, which was causing you issues (both because you had For without Next, and because you were trying to reuse an existing variable) on the basis that wbNew only ever contained 1 worksheet, replaced wbThis with ThisWorksheet, and swapped the .Copy:.PasteSpecial with .Value=.Value to avoid needing the clipboard.
Related
The code I have below does more or less that what title says but every time it reads one file creates a new worksheet and pastes the content there
Code
Sub fileLoop()
Dim mypath As String, myfile As String
mypath = "C:\Users\xxxx\Desktop\test macro\"
myfile = Dir(mypath & "*.xlsx")
Dim ws As Worksheet
Do While myfile <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(mypath & myfile)
Set ws = wb.Sheets(1)
For Each ws In wb.Worksheets
ws.Copy after:=ThisWorkbook.ActiveSheet
Next
wb.Close
myfile = Dir
Loop
End Sub
Files I have
What I get
What I need
I tried changing this line to get the content of files in the same worksheet
For Each ws In wb.Worksheets
ws.Copy after:=ThisWorkbook.ActiveSheet
Next
Change ws.Copy after:=ThisWorkbook.ActiveSheet
To ws.UsedRange.Copy ActiveSheet.Cells(ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1,1)
Also the Set ws = wb.Sheets(1) is useless because you are just resetting it without use in the very next statement!
Try playing around with this:
Option Explicit
Sub fileLoop()
Dim mypath As String, myfile As String
mypath = "C:\Users\xxxx\Desktop\test macro\"
myfile = Dir(mypath & "*.xlsx")
Dim ws As Worksheet
Dim wb As Workbook
Dim rngTarget As Range
Dim numRows As Integer
Set rngTarget = ThisWorkbook.Worksheets("Hoja1").Range("A2:M2")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
numRows = ws.Range("A1").Offset(Rows.Count - 1).End(xlUp).Row
rngTarget.Resize(numRows).Value = ws.Range("A2:M2").Resize(numRows).Value
Set rngTarget = rngTarget.Offset(numRows)
Next ws
wb.Close
myfile = Dir
Loop
Set rngTarget = Nothing
Set wb = Nothing
End Sub
Hey I am quite new to VBA and I am currently trying to export tables from different sheets, if there is an alternation made to it, as CSV data. Currently my code exports all tables from my file. How can I make it export only the current table that I am executing the makro on?
Thank you for your help!
Public Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.name, xlCSV
Next
End Sub
I figured out a way to do it but now the window opens as a CSV file. How do i close the csv file and reopen the worksheet I was working on?
Public Sub SaveWorksheetsAsCsvUndercarriageDefinition()
Dim wbk As Workbook
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set wbk = Workbooks("Vba_Fehlerprüfung.xlsm")
Set xWs = wbk.Worksheets("Undercarriage Definition")
Set folder =
Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
'For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.name, xlCSV
'Next
End Sub
My suggestion would be to use the following sub in order to export a table resp. an listobject
Sub exportListobject(lo As ListObject, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
Set wsNew = wbNew.Sheets(1)
lo.Range.Copy
wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
It will copy the listobject in question into a new workbook, save it as an csv file and close it. The workbook which contains the listobject will not be touched.
If you want to export a single sheet from your workbook you can use a similar sub
Sub exportSheet(sh As Worksheet, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
sh.Copy wbNew.Sheets(1)
Set wsNew = wbNew.Sheets(1)
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
Im eliminating the duplicates, that not give any error.
Then i try to select all the row (not the same each time)
giving a error out of range
MyBook.Sheets("Excel").Range("C1:P1000000").Copy .Sheets("Sheet1").Rows("1")
Dim rg As Range
Dim rg2 As Range
Set rg = Range("F2").CurrentRegion
rg.RemoveDuplicates Columns:=1, Header:=xlYes
Dim MyBook As Workbook, newBook As Workbook
Dim FileNm As String
Set MyBook = ThisWorkbook
FileNm = ThisWorkbook.Path & "\" & "TEST-BOOK.xls"
Set newBook = Workbooks.Add
With newBook
MyBook.Sheets("Excel").Range("C1:P1000000").Copy .Sheets("Sheet1").Rows("1")
'Save new wb with XLS extension
.SaveAs Filename:=FileNm, FileFormat:=xlNormal, CreateBackup:=False
.Close Savechanges:=False
End With
dim newWb as workbook
activesheet.cells.copy
set newWb = workbooks.add
newWb .worksheets(1).cells(1,1).pastespecial
I have an issue runtime error 1004 with the below code, could anyone clarify for me what could be driving this?
Sub Excel1()
Dim rngLoopRange As Range
Dim wsSummary As Worksheet
Dim rngDealers As Worksheet
Set wsSummary = Sheets("PL")
For Each rngLoopRange In Worksheets("AUX").Range("A1:A38")
wsSummary.Range("C12").Value = rngLoopRange.Value
Application.Run "TM1REFRESH"
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\" & Range("C12").Value
ws.Copy before = wb.Worksheets(1)
Next rngLoopRange
Set wsSummary = Nothing
MsgBox "Complete!", vbInformation
End Sub
The above is now saving the file using the name I wanted, can you please advise now why it is giving me an
error '424'
on the sheet copying over. with the code line ws.Copy before = wb.Worksheets(1)
Sub Excel1()
Dim rngLoopRange As Range
Dim wsSummary As Worksheet
Dim rngDealers As Worksheet
Set wsSummary = Sheets("PL")
For Each rngLoopRange In Worksheets("AUX").Range("A1:A38")
wsSummary.Range("C12").Value = rngLoopRange.Value
Application.Run "TM1REFRESH"
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\" & wsSummary.Range("C12").Value
ws.Copy before:=wb.Worksheets(1)
wb.Close savechanges:=True
Next rngLoopRange
Set wsSummary = Nothing
MsgBox "Complete!", vbInformation
End Sub
I want to copy/paste all worksheet inlcuding the values/formula in the cells to another new workbook.
This code just copy the first ws, but not all other. How can I make sure, that all ws are gettin copied and pasted without writing all the names from the ws in the vba-code?
Sub CopyPaste()
Dim ws As Worksheet, wb As Workbook
Set ws = ActiveSheet
Set wb = Workbooks.Add(xlWBATWorksheet)
ws.Range("A1:G10").Copy
wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub
So i assume you will be saving the second workbook for it to be named? therefore just add your path below where you want to save it, also it now retains the sheet names.
I'm not sure why you are getting a debugger error its working fine for me, try this code and see if you still get it?
Sub newworkbook()
Dim WBN As workbook, WBC As workbook, WB As workbook
Dim WS As String
Dim SHT As Worksheet
Set WBN = Workbooks.Add
For Each WB In Application.Workbooks
If WB.Name <> WBN.Name Then
For Each SHT In WB.Worksheets
SHT.Copy After:=WBN.Sheets(WBN.Worksheets.Count)
WBN.Sheets(WBN.Worksheets.Count).Name = (SHT.Name) & " "
Next SHT
End If
Next WB
Application.DisplayAlerts = False
WBN.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
WBN.Application.DisplayAlerts = True
ActiveWorkbook.SaveAs "C:\YOURPATH\timetable_v2.xls" 'change path to whatever
End Sub
You can try as follow:
Sub CopyPaste()
Dim aSheet As Worksheet
Dim workbook As workbook
Dim index As Integer
Set workbook = Workbooks.Add(xlWBATWorksheet)
For Each aSheet In Worksheets
aSheet.Range("A1:G10").Copy
workbook.Sheets(index).Range("A1").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
index = index + 1
Application.CutCopyMode = False
Next aSheet
End Sub
Just had a quick look for you, this seems to do the job:
credit: get digital help
Dim WBN As Workbook, WBC As Workbook, WB As Workbook
Dim WS As String
Dim SHT As Worksheet
Set WBN = Workbooks.Add
For Each WB In Application.Workbooks
If WB.Name <> WBN.Name Then
For Each SHT In WB.Worksheets
SHT.Copy After:=WBN.Sheets(WBN.Worksheets.Count)
WBN.Sheets(WBN.Worksheets.Count).Name = Left(WB.Name, 30 - Len(SHT.Name)) & "-" & SHT.Name
Next SHT
End If
Next WB
Application.DisplayAlerts = False
WBN.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
WBN.Application.DisplayAlerts = True
I just deleted WBN.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
And it works fine
The new workbook is saved as an .xlsx file, but of course I Need it as an .xlsm file....when I just added it into the path, it doesnt work
ActiveWorkbook.SaveAs "U:\Excel\timetable_v2.xlsm"