I have 3 workbooks
source workbook
target workbook
reference workbook - (Containing the macro which visible across all workbooks)
Is it possible to change switch between Active workbook ( target workbook) and ( source workbook which was active workbook).
Activate doesn't seem to help me, I do not if this is a bug or what it is. I have stopped in this step for quite sometime now.
This workbook function takes me back to reference workbook.
Hope my question is clear. Appreciate your help.
' My code is in a test macroworkbook
' I am having a workbook opened 1.xlsx
' Opening a workbook countrypricelist.xls
'running the code from
Dim sourcewb As Workbook
Dim targetWorkbook As Workbook
Dim filter As String
Dim filter2 As String
Dim rw As Long
Dim x As Range
Dim y As Range
Set sourcewb = ActiveWorkbook
Set x = sourcewb.Worksheets(1).Range("A:F")
Dim sourceSheet As Worksheet
Set sourceSheet = sourcewb.Worksheets(1)
MsgBox sourceSheet.Name
x.Select
MsgBox sourceSheet.Name
x.Select
MsgBox sourcewb.Name ' This gives me sourceworkbook name.
filter = "(*.xls),*.xls"
Caption = "Please Select an input file "
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename(filter, , Caption)
Set targetWorkbook = Application.Workbooks.Open(Filename)
Set y = targetWorkbook.Worksheets(1).Range("A:F")
y.Select
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
MsgBox targetSheet.Name
Set targetWorkbook = ActiveWorkbook
MsgBox targetWorkbook.Name 'This gives me target workbook name
y.Select
sourcewb.Activate
MsgBox sourcewb.Name ' Source workbook becomes same as targeworkbook.
x.Select
MsgBox sourcewb.Name & " This is the source workbook "
MsgBox targetWorkbook.Name & " This is the target workbook "
With sourcewb.Worksheets(1)
For rw = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(rw, 3) = Application.VLookup(Cells(rw, 2).Value2, x, 3, False)
Cells(rw, 4) = Application.VLookup(Cells(rw, 2).Value2, x, 4, False)
Cells(rw, 5) = Application.VLookup(Cells(rw, 2).Value2, x, 5, False)
Next rw
End With
MsgBox "All required columns from source mapped to target file "
MsgBox "Trying to map from target to source "
Set sourcewb = ActiveWorkbook
MsgBox ActiveWorkbook.Name
Application.ScreenUpdating = False
So If I change the line sourcewb = Thisworkbook my reference is changed to source code to workbook which is not my desired workbook as it contains many other macros for other activities. Hope this is code is fine.
The Excel Workbook Object allows you to programatically open, edit and close any workbook, not just the currently 'Activated' one.
Example:
Dim wb as Excel.Workbook, otherwb as Excel.Workbook
Dim ws as Excel.Worksheet, otherws as Excel.Worksheet
Set wb = Workbooks.Open "somefile.xlsx"
Set otherwb = Workbooks.Open "otherfile.xlsx"
Set ws = wb.Sheets(1)
Set otherws = otherwb.Sheets(1)
' do stuff
ws.Cells(1,1) = otherws.Cells(1,1)
'save changes
wb.Save
Related
Is there a way to save the active/selected worksheet without having to specify sheets(1)?
The code below is execute via command button and will take the worksheet "Quote" copy to a new workbook, and then prompt to save under the downloads directory.
I'm also trying to get that button to save whichever sheet is selected, it could be Quote or Sheet1, but not both.
Private Sub CommandButton4_Click() ' save worksheet
'Gets the name of the currently visible worksheet
Filename = ActiveSheet.Name
'Puts the worksheet into its own workbook
ThisWorkbook.ActiveSheet.Copy
'Saves the workbook - uses the name of the worksheet as the name of the new workbook
'Filename = Range("A1")
'ActiveWorkbook.Save
Dim NameFile As Variant
With Worksheets("Quote")
'NameFile = .Range("A1") & "_" & .Range("B5") & "_" & ".xls"
End With
NameFile = Application.GetSaveAsFilename(InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & NameFile, Filefilter:="Fichier Excel (*.xls), *.xls")
If NameFile = False Then
MsgBox "File not saved"
Else
ActiveWorkbook.SaveAs Filename:=NameFile
End If
'Closes the newly created workbook so you are still looking at the original workbook
ActiveWorkbook.Close
End Sub
This Sub creates a new Workbook from a sheet. But you must have a way to call this Sub of every sheet, or a better place is a button in the ribbon witch in it's handler: Call NewBookOfSheet(ActiveSheet).
Public Sub NewBookOfSheet(ws As Worksheet)
Dim nwb As Workbook, curwb As Workbook
If ws Is Nothing Then Exit Sub
Set curwb = ws.Parent
Set nwb = Workbooks.Add
curwb.Activate
ws.Select
ws.Copy Before:=nwb.Sheets(1)
nwb.Activate
Application.Dialogs(xlDialogSaveAs).Show ws.Name
End Sub
Copy the Active Worksheet to a New Workbook
Private Sub CommandButton4_Click() ' save worksheet
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim sws As Worksheet: Set sws = ActiveSheet
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
Dim dws As Worksheet: Set dws = dwb.Sheets(1) ' the one and only
Dim dwbName: dwbName = Application.GetSaveAsFilename( _
InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & dws.Name, _
FileFilter:="Fichier Excel (*.xls), *.xls")
If dwbName = False Then
MsgBox "File not saved", vbCritical
Else
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dwbName, FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
End If
dwb.Close SaveChanges:=False
' Now 'dws' and 'dwb' are invalid but still 'Not Nothing'.
' On the other hand, 'sws' still points to the (initial) source worksheet.
' If you need to reference the source workbook use:
'Dim swb As Workbook: Set swb = sws.Parent
End Sub
I'm trying to run a macro that I can choose an Excel file where I can filter date and copy (in a specific sheet) and paste the data back to my active workbook (in a specific sheet).
I tried various forums about workbook.open errors but still couldn't get to fix my formula.
Sub CopyFilteredValuesToActiveWorkbook()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim rngSource As Range, rngDest As Range
Dim Fname As String
Dim strName As String 'for filter
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set wbSource = Workbooks.Open(Fname) 'ERROR POINTS THIS LINE
Set wsSource = wbSource.Worksheets("Table 1")
strName = InputBox("Input Year")
wsSource.Range("A:A").AutoFilter Field:=3, Criteria1:="=* & strName & *", Operator:=xlAnd
Set rngSource = wsSource.Range("A:K")
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Sheet3")
Set rngDest = wsDest.Range("A:K")
rngDest.Value = rngSource.Value
wbSource.Close (False) 'Close without saving changes
End Sub
I've got over 200 workbooks that I need to merge, the code below will merge the workbooks and add all the sheets into one workbook.
In that workbook the sheets are being named Sheet 1 (1), Sheet 1 (2) and so on.
If the sheet was copied from Workbook1 the sheet name would be workbook 1
Sub mergeFiles()
'Merges all files in a folder to a main file.
'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet
'Close the source workbook
sourceWorkbook.Close
Next i
End Sub
Add this in you For Each loop
Dim j as integer ‘Add to top of your sub
j = 0 ‘Add inside for loop
For Each tempWorkSheet In sourceWorkbook.Worksheets
j= j+1
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
ActiveSheet.Name = sourceWorkBook.Name & “ - “ & j ‘Added Line of code to rename copied tab
Next tempWorkSheet
As long as your workbook names aren’t too long or duplicate, it should be good
Merge Files
Code Issues
You have declared numberOfFilesChosen as Variant:
Dim numberOfFilesChosen, i As Integer ' Wrong
Dim numberOfFilesChosen as Integer, i As Integer ' OK
You have declared mainWorkbook as Variant:
Dim mainWorkbook, sourceWorkbook As Workbook ' Wrong
Dim mainWorkbook as Workbook, sourceWorkbook As Workbook ' OK
Such a code should be in the Workbook (mainWorkbook) where the
Worksheets are being imported, so you don't need a variable, just use
ThisWorkbook. Then in combination with the With statement, you
can use e.g. .Sheets(.Sheets.Count).
You are changing between sheets and worksheets. When you use mainWorkbook.Worksheets.Count, this might not necessarily be the last sheet, so it would be more correct to use mainWorkbook.Sheets.Count especially for the added sheet counter to function correctly.
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Sheets.Count) ' Preferable
When you use sourceWorkbook.Close, you might be asked to save the workbook. Using
sourceWorkbook.Close False ' Preferable
will close the workbook without saving changes.
The code will fail if you run it another time, because the sheet names
it will try to create are the same. Therefore I have added
DeleteWorksheetsExceptOne which I used while testing the code.
The Code
Sub mergeFiles()
'Merges all files in a folder to a main file.
'Define variables:
Dim tempFileDialog As FileDialog
Dim sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
Dim numberOfFilesChosen As Long, i As Long, j As Long
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
With ThisWorkbook
'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
j = 0
'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
j = j + 1
tempWorkSheet.Copy After:=.Sheets(.Sheets.Count)
' Rename newly added worksheet to the name of Source Workbook
' concatenated with "-" and Counter (j).
.Sheets(.Sheets.Count).Name = sourceWorkbook.Name & "-" & j
Next
'Close the source workbook. False for not saving changes.
sourceWorkbook.Close False
Next
End With
End Sub
Delete All Worksheets But One
'*******************************************************************************
' Purpose: Deletes all Worksheets in the ActiveWorkbook except one.
' Danger: This code doesn't ask anything, it just does. In the end you will
' end up with just one worksheet (cStrWsExcept) in the workbook
' (cStrWbPath). If you have executed this code and the result is not
' satisfactory, just close the workbook and try again or don't. There
' will be no alert like "Do you want to save ..." because of the line:
' ".Saved = True" i.e. "objWb.Saved = True".
' Arguments (As Constants):
' cStrWbPath
' The path of the workbook to be processed. If "", then ActiveWorkbook is
' used.
' cStrWsExcept
' The worksheet not to be deleted. If "", then the Activesheet is used.
'*******************************************************************************
Sub DeleteWorksheetsExceptOne()
Const cStrWbPath = "" ' if "" then ActiveWorkbook
Const cStrWsExcept = "Sheet1" ' if "" then ActiveSheet
Dim objWb As Workbook
Dim objWsExcept As Worksheet
Dim objWsDelete As Worksheet
If cStrWbPath = "" Then
Set objWb = ActiveWorkbook
Else
Set objWb = Workbooks(cStrWbPath)
End If
With objWb
If cStrWsExcept = "" Then
Set objWsExcept = .ActiveSheet
Else
Set objWsExcept = .Worksheets(cStrWsExcept)
End If
' To suppress the "Data may exist in the sheet(s) selected for deletion.
' To permanently delete the data, press Delete." - Alert:
Application.DisplayAlerts = False
For Each objWsDelete In .Worksheets
If objWsDelete.Name <> objWsExcept.Name Then
objWsDelete.Delete
End If
Next
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
.Saved = True
Application.DisplayAlerts = True
End With
End Sub
'*******************************************************************************
I have workbook, I loop through and save each sheet as a csv. The problem is when the loop finishes Excel prompts me to save. If I click "Save", then last worksheet is overwritten with whichever sheet the excel workbook opens on.
If click "Don't Save" everything remains saved with the proper data, but I can't rely on the user to click "Don't Save" every time so I need to find where my code is over writing the data when saved.
How do I keep my csv sheet from being overwritten?
Sub LipperFormat()
'Create Workbook
Dim wb As Workbook
'Get FilePath
Dim wbActive As Workbook
Set wbActive = ActiveWorkbook
Dim wsActive As Worksheet
Set wsActive = wbActive.Worksheets(1)
'Get File Path
Dim filePath As String
Dim rngActive As Range
Set rngActive = wsActive.Cells(1, 2)
filePath = rngActive.Value
'Open File
Set wb = Workbooks.Open(filePath)
'Create Copy of file and CSV
Dim copyFilePath As String
Dim fileExtension As String: fileExtension = "_OG.xlsx"
copyFilePath = Left(filePath, Len(filePath) - 5) + fileExtension
wb.SaveCopyAs copyFilePath
'Loop through worksheets
Dim WS_Count As Integer
Dim i As Integer
WS_Count = wb.Worksheets.Count
For i = 1 To WS_Count
Dim col As Integer
Dim ws As Worksheet
Set ws = wb.Sheets(i)
'Save As CSV
Dim sheetName As String: sheetName = ws.Name
Dim csvFilePath As String
Dim csvSheet As Worksheet
cvsFilePath = Left(filePath, Len(filePath) - 5) + "__" + sheetName
'ws.Name = sheetName
ws.SaveAs FileName:=cvsFilePath, FileFormat:=xlCSV, CreateBackup:=False
Next i
'wb.Save
wb.Close
End Sub
You code is too large for no benefits. I cleaned it and corrected your mistakes and also added necessary pieces to not ask the users for anything:
Sub LipperFormat()
Dim filePath As String
Dim csvFileName As String
Dim ws As Worksheet
Dim wb As Workbook
Application.DisplayAlerts = False
'define parameters
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1) 'it is better to define it with the name, not with its index
filePath = ws.Cells(1, 2).Value
'Open File
Set wb = Workbooks.Open(Filename:=filePath, ReadOnly:=True)
'loop and save as csv
For Each ws In wb.Worksheets
csvFileName = wb.Path & "\" & Left(wb.Name, Len(wb.Name) - 5) & "__" & ws.Name
ws.Copy
ActiveWorkbook.SaveAs Filename:=csvFileName, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Next ws
'close WB
wb.Close
Application.DisplayAlerts = True
End Sub
I am trying to do a copy and paste of data in between workbooks and worksheets. I have the following codes but it seems to be taking up much time. I was wondering if there is any simpler way in copying?
Sub Test1()
Dim wb As Workbook, x As String, y As String, wb1 As Workbook
For Each wb In Application.Workbooks
If wb.Name <> ThisWorkbook.Name Then x = wb.Name
Next wb
Workbooks(x).Activate
Sheets("Sheet1").Range("A:E").Copy
ActiveWindow.WindowState = xlMinimized
Sheets("Sheet1").Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll
Sheets("Sheet1").Range("A1").Select
Workbooks(x).Activate
ActiveWindow.WindowState = xlNormal
Sheets("Sheet1").Range("F:F").Copy
ActiveWindow.WindowState = xlMinimized
Sheets("Sheet1").Range("G:G").Select
Selection.PasteSpecial Paste:=xlPasteAll
Workbooks(x).Activate
ActiveWindow.WindowState = xlNormal
End Sub
Some headsup:- Use
Sub Test1()
Application.Screenupdating = False
'yourcode
Application.Screenupdating = True
End Sub
in your code to execute it faster
for copy paste a short verion that can be used is
Sheets("Sheet1").Range("F:F").Copy Sheets("Sheet1").Range("G:G")
Instead of activating certain books try pasting directly to the destination as mentioned in the above code.
you can remove "ActiveWindow.WindowState = xlMinimized"
EDIT:- as per added comments
dim wb1 as workbook
dim wb2 as workbook
set wb1 = ("Filename.xlsx")
set wb2 = ("filename.xlsx")
wb1.sheetname.range("A1").copy wb2.sheetname.range("A1")
you can further decalre your sheetname as well
dim ws as worksheet
set ws = worksheets("Sheetname")
Edit as per second comment (add variable to newly opened workbook)
Dim path as variant
dim wsb as workbook
path = \\C:your path ' not the sheet name
Set wsb = Workbooks.Open(filename:=myfolder & "\" & "filename".xlsm")
'your codes
I got some idea from JMAX and found a way which is as follows:
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet1").Range("A:B").Copy
wb.Worksheets("Sheet1").Activate
wb.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteAll
End Sub