Deactivate entire sheet selection after paste - vba

I recently asked a question and received a great answer on this site, but I am now running into a different problem. The code below works well for running through each workbook in a folder, copying a sheet's contents, and pasting those contents into a master workbook exactly how I would like:
Sub ConslidateWorkbooks()
'Code to pull sheets from multiple Excel files in one file directory
'into master "Consolidation" sheet.
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim wbName As String
With ActiveSheet
Range("A1").Activate
End With
Application.ScreenUpdating = False
FolderPath = ActiveWorkbook.Path & "\"
Filename = Dir(FolderPath & "*.xls*")
wbName = ActiveWorkbook.Name
Do While Filename <> ""
If Filename <> wbName Then
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
copyOrRefreshSheet ThisWorkbook, Sheet
Next Sheet
Workbooks(Filename).Saved = True
Workbooks(Filename).Close
ActiveSheet.Range("A1").Activate
End If
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
End Sub
The problem I am having now: After the paste is completed, each sheet in the master workbook has all of its cells selected, as though I Ctrl+A'd the entire sheet. I would like to get rid of this. It is a small task which I tried to accomplish in the line ActiveSheet.Range("A1").Activate within the Do While .. loop, but it has not worked for me.
EDIT:
I found a solution that works in this case. I am not sure why this was necessary, because the comments and answers in this thread seem like they should work, but they did not. I call this sub before I turn screenupdating to True in the main sub:
Sub selectA1()
Worksheets(1).Activate
Dim Sheet As Worksheet
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Sheet.Range("A1").Select
Next Sheet
Worksheets(1).Activate
End Sub
I realize this is more complicated than it should be, but it works for my purposes.

In your copy sub, add in another code in the loop that will select a cell which should deactivate the total used range selection and just select the coded range.
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
ws.range("A1").select
Application.CutCopyMode = False
End If
End Sub
I added ws.range("A1").select which should do as I described above.

Related

VBA Code to Copy Non Blank Cells From one Sheet to Another

I'm trying to write a VBA code to copy "Non-Blank" cells from one file to another. This code selects the last Non Blank row, but for the column it's copying A4 to AU. I'd like to copy columns A4 to LastcolumnNotblank and also last row. So basically copy A4 to (LastColumn)(LastRow)Not Blank
Would be really grateful if someone can help by editing the below code. Many thanks.
Sub Export_Template()
'' TPD
File_name = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If File_name <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRow
If Left(ActiveSheet.Range("A" & i).Value, 1) <> "" Then lastactiverow = i
Next i
'MsgBox (lastactiverow)
ActiveSheet.Range("A4:AU" & lastactiverow).Select
Selection.Copy
Set NewBook = Workbooks.Add
ActiveSheet.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs Filename:=File_name, FileFormat:=51
ActiveWorkbook.Close (False)
End If
End Sub
The code below will preserve your ActiveSheet range and use SaveAs to save to a new workbook with your specific name, without all the extra crap. It deletes all the sheets except for the ActivSheet, and deletes the first three rows, then using SaveAs to save to ThisWorkbook.Path. Your macro enabled workbook will not be changed.
I actually don't like to use ActiveSheet due to the obvious problems, but since you were using it i kept it. I would suggest you use the name of the worksheet.
Sub SaveActiveSheetRangeAsNewWorkbook()
Dim ws As Worksheet
Application.DisplayAlerts = False
With ThisWorkbook
For Each ws In Application.ThisWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.Delete
End If
Next
.Sheets(1).Range("A1:A3").EntireRow.Delete
.SaveAs Filename:="Engineering TPD", FileFormat:=xlOpenXMLWorkbook
End With
Application.DisplayAlerts = True
End Sub
I'm assuming that Col A is a good indicator of where to find your last used row
Also assuming that Row 1 is a good indicator of where to find your last used column
You need to change Sheet1 on 3rd line of code to the name of your sheet that has the data to be copied
You need to declare variables (Use Option Explicit)
Avoid .Select and .Selection at all costs (none are found in below solution)
You did not re-enable ScreenUpdating and DisplayAlerts
This is tested and works A-OK
Option Explicit
Sub Export_Template()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim NewBook As Workbook
Dim LRow As Long, LCol As Long
Dim FileName
FileName = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If FileName <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
LCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Range(ws.Cells(4, 1), ws.Cells(LRow, LCol)).Copy
NewBook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
NewBook.SaveAs FileName:=FileName, FileFormat:=51
NewBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub

VBA trying to specify a newly created workbook rather than activeworkbook (to paste some data into the new one)

I've got some code that copies some data, then I want it to create a new workbook and paste the copied data into the new workbook. At the moment the code uses ActiveSheet.Range("A1").PasteSpecial etc which is fine if the newly created workbook is the active sheet but if it isnt that obviously doesn't work. here's the entire sub (with some stop markers as i've been debugging it):
Sub ExportToCSV()
Dim ws As Worksheet, xFolder As String, xName As String
Dim InitialFoldr$
InitialFoldr$ = "L:\107xxx\1077898 A34 Oxford junctions 1718\200 M & A"
MsgBox ("Choose where to save the Paramics demands")
xFolder = GetFolder(InitialFoldr$)
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "*PDMND" Then
xName = ws.Name
ws.Range("BJ4:CK82").Copy
'Stop
With CreateObject("Excel.Application")
.Workbooks.Add
.Visible = True
End With
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
Stop
ActiveWorkbook.SaveAs Filename:=xFolder + "\" + xName + ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End If
'Stop
Next
End Sub
After the with loop to create the new workbook, i want to make a variable that refers to the new workbook and then i can use the variable to paste the data in the right place - or something akin to this - to replace the ActiveSheet.Paste bit. How do I accomplish this?
Edit: I have used the information in the similar answer here so my code now looks like this:
xFolder = GetFolder(InitialFoldr$)
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "*PDMND" Then
xName = ws.Name
ws.Range("BJ4:CK82").Copy
Set oWb = Workbooks.Add
oWb.Range("A1").PasteSpecial Paste:=xlPasteValues
Stop
But now Excel crashes without fail after I select the save folder. Is there an obvious reason for this?
When you create the new workbook, save the workbook object so you can reference it later... like this:
Before you start your loop add:
Dim wbNew as Workbook
Then inside your loop...
With CreateObject("Excel.Application")
Set wbNew = .Workbooks.Add
.Visible = True
End With
wbNew.WorkSheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues

Merge Multiple Workbooks that have multiple worksheets using VBA

I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub

Copy/paste values from multiple sheets, but not all sheets, into one sheet

I am needing to copy cells B3:W400 from multiple sheets (will have varying names each time it is run) and paste values into "CombinedPlans", appending each new selection under the last. I need 3 sheets excluded from the code: IBExport, MonthlyIBs, and Combined Plans.
A lot of googling with trial and error has given me the following code, which I got to work in my "practice" workbook. Now that I have put it into my production workbook, it is no longer copying any sheets. It just skips straight to the message box. What am I doing wrong?
Sub consolidatetest()
Sheets("CombinedPlans").Select
Range("B3:W1048576").Select
Selection.ClearContents
Dim J As Integer
Dim sh As Worksheet
Const excludeSheets As String = "QBExport,MonthlyIBs,CombinedPlans"
On Error Resume Next
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, Split(excludeSheets, ","))) Then
Application.GoTo Sheets(sh.Name).[b3]
Range("B3:W400").Select
Selection.Copy
Worksheets("CombinedPlans").Activate
Range("B1048576").End(xlUp).Offset(rowOffset:=1, columnOffset:=0).PasteSpecial xlPasteValues
End If
Next
Application.CutCopyMode = False
MsgBox "Complete!"
End Sub
This should work. If you have still problems, make sure that the Sheet CombinedPlans is indeed so named.
Sub consolidatetest()
Dim wb As Workbook
Dim sh_CombPlans As Worksheet
Set wb = ThisWorkbook
Set sh_CombPlans = wb.Sheets("CombinedPlans")
sh_CombPlans.Range("B3:W1048576").ClearContents
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Select Case sh.Name
Case "QBExport", "MonthlyIBs", "CombinedPlans":
'Do Nothing
Case Else
sh.Range("B3:W400").Copy
sh_CombPlans.Range("B1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End Select
Next
Application.CutCopyMode = False
MsgBox "Complete!"
End Sub

Run macro on all files open in taskbar one by one

My work is regarding formating 100 of files everyday. though i have a macro desined for the purpose but i have to run the macro on each and every file one after saving previous.
my question is how can i be able to run my macro on these opened workbooks in one step. As i save one it would run on other one in the queue.
Put the following macro in a "BASE" workbook as Passerby mentioned
Sub SO()
Dim macroList As Object
Dim workbookName As String
Dim wbFullPath
Dim macroName As String
Dim currentWb As Workbook
Dim masterWb As Workbook ' the Excel file you are calling this procedure from
Dim useWbList As Boolean
Dim height As Long, i As Long
Dim dataArray As Variant
useWbList = False ' DEFINE which input method
Set macroList = CreateObject("Scripting.Dictionary")
If useWbList Then
' you can also from the dictionary from 2 columns of an excel file , probably better for management
With masterWb.Worksheets("Sheet1") '<~~ change Sheet1 to the sheet name storing the data
height = .Cells(.Rows.Count, 1).End(xlUp).Row ' Assume data in column A,B, starting from row 1
If height > 1 Then
ReDim dataArray(1 To height, 1 To 2)
dataArray = .Range(.Cells(1, 1), .Cells(height, 2)).Value
For i = 1 To height
macroList.Add dataArray(i, 1), dataArray(i, 2)
Next i
Else
'height = 1 case
macroList.Add .Cells(1, 1).Value, .Cells(1, 2).Value
End If
End With
Else
' ENTER THE FULl PATH in 1st agrument below, Macro Name in 2nd argument
' Remember to make sure the macro is PUBLIC, try to put them in Module inside of Sheets'
macroList.Add "C:\Users\wangCL\Desktop\Book1.xlsm", "ThisWorkbook.testing"
'macroList.Add "FULL PATH", "MACRO NAME"
'macroList.Add "FULL PATH", "MACRO NAME"
'macroList.Add "FULL PATH", "MACRO NAME"
End If
Application.DisplayAlerts = False
For Each wbFullPath In macroList.keys
On Error GoTo 0
macroName = macroList.Item(workbookName)
workbookName = Mid(wbFullPath, InStrRev(wbFullPath, "\") + 1)
Err.Clear
On Error Resume Next
Set currentWb = Nothing
Set currentWb = Workbooks(workbookName) ' see if the workbook is already open
If Err.Number <> 0 Then
' open the workbook if workbook NOT opened
Set currentWb = Workbooks.Open(workbookName, ReadOnly:=True)
End If
On Error GoTo 0
' run the macro
Application.Run workbookName & "!" & macroList.Item(wbFullPath)
'close the workbook after running the macro
currentWb.Close saveChanges:=False
Set currentWb = Nothing
Next wbFullPath
End Sub
Hope it helps and please let me know if there's anything unclear
I have got my solve using below code.
Sub OpenAllWorkbooksnew()
Set destWB = ActiveWorkbook
Dim DestCell As Range
Dim cwb As Workbook
For Each cwb In Workbooks
**Call donemovementReport**
ActiveWorkbook.Close True
ActiveWorkbook.Close False
Next cwb
End Sub