I am looking for a macro to paste some data onto a moving range. I already have a cell that tells me the number of the next non empty column and this is the code I currently use:
Dim OpenFileName As String
Dim wb As Workbook
'Select and Open workbook
OpenFileName = Application.GetOpenFilename()
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
'Get data EXAMPLE
ThisWorkbook.Sheets("Teleselling 17").Range("I9:I289")*this should be dynamic, I want to paste data in a moving range*.Value = wb.Sheets("TELESELLING INBOUND").Range("L9:L289").Value
wb.Close SaveChanges:=False
MsgBox ("Done!")
Use the newly opened workbook/worksheet/range to define the scope of the value transfer.
with wb.workSheets("TELESELLING INBOUND").Range("L9:L289")
ThisWorkbook.workSheets("Teleselling 17").Range("XFD9").end(xltoleft).offset(0, 1).resize(.rows.count, .columns.count) = .value
end with
Related
I have some VBA code which I use in another workbook to resize a table to be 1 row and delete the contents of a data table to initialize a workbook. Then a file prompt opens asking the user to select the appropriate file for processing. For some reason, I am getting a
"Run-time error '91': Object variable or With block variable not set"
The code is a copy and paste from the other workbook and I have adjusted the names of the variables, workbooks, worksheets, and table names.
workbook is called "IMD Processing.xlsm" with 2 sheets titled "IMD" and "Raw". The "Raw" sheet has a table with the name "tbl_raw" and the "IMD" sheet has a table with the name "tbl_imd".
Any guidance would be greatly appreciated.
Option Explicit
Sub IMDAutomation()
Dim fileName As String 'Filename string
Dim wb_macro As Workbook 'Macro workbook
Dim ws_macro_imd As Worksheet 'Macro worksheet
Dim ws_macro_raw As Worksheet 'Macro raw worksheet
Dim wb_imd As Workbook 'IMD Workbook for processing
Dim ws_imd As Worksheet 'IMD Worksheet for processing
Dim objTable As ListObject 'Table of raw data
Dim tbl_raw As ListObject 'Raw table in macro workbook
Dim tbl_imd As ListObject 'IMD table in macro workbook
Dim vals As Variant 'Array to store values
Dim lrow As Long 'Variable used to determine number of rows in data table
Set wb_macro = ThisWorkbook
Set ws_macro_imd = Sheets("IMD")
Set ws_macro_raw = Sheets("Raw")
'============ Initialize macro workbook - clearing data ============'
'Clear the raw data in the macro workbook
Set tbl_raw = ws_macro_raw.ListObjects("tbl_raw")
With tbl_raw.DataBodyRange
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
End If
End With
tbl_raw.DataBodyRange.Rows(1).ClearContents
'Clear the IMD data in the macro workbook
Set tbl_imd = ws_macro_imd.ListObjects("tbl_imd")
With tbl_imd.DataBodyRange
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
End If
End With
'============ Locate Raw Data File ============'
'Open file dialog to locate the Workforce Review raw data workbook exported from system
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Select the IMD file"
.Filters.Clear
.Filters.Add "Custom Excel Files", "*.xlsx, *xls, *csv"
.Show
fileName = .SelectedItems.Item(1)
End With
If InStr(fileName, ".xlsx") = 0 Then
Exit Sub
End If
Workbooks.Open fileName
'Set the Workforce Review raw workbook
Set wb_imd = ActiveWorkbook
'Set the worksheet
Set ws_imd = wb_imd.ActiveSheet
lrow = ws_imd.Cells(ws_imd.Rows.Count, 2).End(xlUp).Row
vals = ws_imd.Range("A2:CU" & lrow)
Application.CutCopyMode = False
Application.CutCopyMode = True
End Sub
UDPATE WITH SOLUTION
Thanks to #Variatus for the solution.
I did not have a data row in my table so I created one and now it's working.
This should work to handle cases where there is no row in the table. If tbl_raw.DataBodyRange Is Nothing Then InsertRowRange Else (Code to clear the table)
Probably the object that is being searched for by Set tbl_raw = ws_macro_raw.ListObjects("tbl_raw") does not exist in the new workbook and hence referencing through With tbl_raw returns this error
I have written VBA code that opens up a destination workbook, copies one of the worksheets, and pastes it into the current workbook.
When I run it a second or third time etc... instead of overwriting the current worksheet, it creates a completely new one.
Ex: Worksheet is called "data", first time it transfers "data", second time "data(2)".
I have another worksheet that uses VLOOKUP function to look at some cells of this data worksheet, so it is crucial that it has correct name "data".
I thought about deleting the current (data) file before running the macro, but what if something crashes and I lose my worksheet? Is there a better solution?
NOTE: I am running the macro from the main workbook to get the sheet to be copied from the external workbook.
Sub UpdateT()
Dim wb As Workbook
Dim aw As Workbook
'Open 2nd Workbook
Set aw = Application.ActiveWorkbook
Set wb = Workbooks.Open(Filename:="C:\Users\yilmadu00\Desktop\T.xlsx")
'Copy To Different Workbook
wb.Sheets("data").Copy After:=aw.Sheets("Data1")
'Close 2nd Workbook
aw.Save
wb.Close
aw.Sheets("data").Visible = False
ActiveWorkbook.Protect ("Password")
End Sub
Function to check whether worksheet exists (credits to #ScottCrainer):
Function SheetExists(ws As String)
SheetExists = Not IsError(Application.Evaluate(ws & "!A1"))
End Function
NOTE:
It does have the issue: if A1 on the sheet contains an error it will return a false negative.
ActiveWorkbook vs ThisWorkbook, Sheets vs Worksheets
You have used 'Activeworkbook' and 'Sheet(s)' in the code so I played along.
But
Although you can have a third workbook to run the code from, I'm guessing you are running the code from a module in the 'ActiveWorkbook'. If this is true, it would be more correct to use 'ThisWorkbook' instead which always refers to the workbook that contains the code (module), to avoid accidentally running the code on a third workbook.
Sheet(s) refers to Worksheet(s) and Chartsheet(s), again I'm guessing there are no chartsheets involved in this code, therefore it would be more correct to use 'Worksheet(s)' instead of 'Sheet(s)'.
Sub UpdateT()
Const cStrPath As String = "C:\Users\yilmadu00\Desktop\T.xlsx"
Const cStrAfter As String = "Data1"
Const cStrName As String = "data"
Const cStrOld As String = "data_old"
Dim aw As Workbook '1st workbook, 'ActiveWorkbook'
Dim wb As Workbook '2nd workbook
Dim oWs As Sheet 'Each sheet in workbook 'aw'
Dim blnFound As Boolean 'True if sheet(cStrName) was found
Set aw = ActiveWorkbook 'Create a reference to the ActiveWorkbook
Set wb = Workbooks.Open(Filename:=cStrPath) 'Open 2nd Workbook
With aw
' .UnProtect ("Password")
'Check each sheet in workbook 'aw'.
For Each oWs In aw.Sheets
With oWs
'Check if there already is a sheet with the name 'cStrName'.
If .Name = cStrName Then
.Name = cStrOld 'Rename the sheet.
blnFound = True 'Sheet(cStrName) was found.
Exit For 'Immediately stop checking, there can only be one.
End If
End With
Next
End With
With wb
'Copy sheet from 2nd workbook ('wb') to workbook 'wa'.
.Sheets(cStrName).Copy After:=aw.Sheets(cStrAfter)
.Close 'Close 2nd workbook ('wb').
End With
With aw
With Application
If blnFound = True Then 'Sheet(cStrName) was found.
.DisplayAlerts = False 'Disable showing delete message.
aw.Sheets(cStrOld).Delete 'Delete old version of sheet.
.DisplayAlerts = True
End If
End With
.Sheets(cStrName).Visible = False 'Hide sheet named 'cStrName'
.Protect ("Password")
.Save 'Save workbook 'aw'.
End With
End Sub
The next time you want to do something with the sheet you have to unprotect it or the code will fail. Hidden sheets can be deleted with no problems.
(Beginner VBA coder here!)
Does anyone know how to extract multiple, specific cell data from multiple closed workbooks that have the same worksheet format?
I am currently tasked to copy very specific data from certain cells from many different and new (but same format) sources and transfer them into another group of specific cells in an existing masterlist with different worksheets.
This is the code I wished would help, but it is lacking in too many ways as compared to what I need...
Sub Importsheet()
Dim Importsheet As Worksheet
'import worksheet from a closed workbook
Sheets.Add Type:= _
'e.g. directory below
"C:\Users\Loli\Desktop\Testing1.xlsx"
End Sub
This code helps me get the sheets out of the closed source workbook but not the specifically placed cells in the closed source excel. It also can't paste the data in specifically placed cells in different sheets in the destination excel.
It is very difficult to completely understand your requirements as it seems like sometimes you want to copy a range and some other times a single cell, so to point you in the right direction my answer only shows how to open and copy the relevant Sheet into your master workbook to then be able to reference the cell/ranges you want
(I would once you get your data then delete the Worksheet, so that your master doesn't suddenly becomes massive in size):
Sub ImportSheet()
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") 'open dialog to choose the file you want, you can change this to loop through a folder if they are all in there.
If sImportFile = "False" Then 'check if a file was selected before importing
MsgBox "No File Selected!"
Exit Sub
Else
vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open Filename:=sImportFile 'open the selected file
Set wbBk = Workbooks(sFile)
With wbBk
If SheetExists("Raw_Data") Then ' you should change this to the date, you can do this easily by using a variable such as if SheetExists(variableDate) then, where variableDate = "12/12/2017" or something similar
Set wsSht = .Sheets("Raw_Data")
wsSht.Copy before:=sThisBk.Sheets("Sheet1") 'copy the worksheet into your master
'WsSht.range("A1:B2").copy Destination:=sThisBk.Sheets("Temp").Range("A1").paste xlpastevalues 'use this to copy a specified range in this case A1:B2 to a sheet in master workbook called Temp A1
Else
MsgBox "There is no sheet with name :Raw_Data in:" & vbCr & .Name
End If
wbBk.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function
I'm merging Excel workbooks into one "summary.xls" using a VBA macro. The macro is executed from another open workbook. This original workbook has some formulas containing links to "summary" (like ='C:\[Summary.xls]Cell'!E3). For the process of merging, the original workbook "summary.xls" is deleted and rewritten. After rewriting all the formulas with the original links to summary have #ref! written in it and are broken and can not be automatically updated (='C:\[Summary.xls]#REF'!E4). The following passage is the one causing the mistake:
Workbooks(Filename).Close (False) 'add False to close without saving
' Kill srcFile 'deletes the file
Filename = Dir()
Does somebody has a suggestion how to solve the problem?
Whole code is based on that suggestion:
Option Explicit
Function IsSheetEmpty(sht As Worksheet) As Boolean
IsSheetEmpty = Application.WorksheetFunction.CountA(sht.Cells) = 0
End Function
Sub GetSheets()
Dim Path, Filename As String
Dim Sheet As Worksheet
Dim newBook As Workbook
Dim appSheets As Integer
Dim srcFile As String
Dim dstFile As String
Application.ScreenUpdating = False 'go faster by not waiting for display
'--- create a new workbook with only one worksheet
dstFile = ActiveWorkbook.Path & "AllSheetsHere.xlsx"
If Dir(dstFile) <> "" Then
Kill dstFile 'delete the file if it already exists
End If
appSheets = Application.SheetsInNewWorkbook 'saves the default number of new sheets
Application.SheetsInNewWorkbook = 1 'force only one new sheet
Set newBook = Application.Workbooks.Add
newBook.SaveAs dstFile
Application.SheetsInNewWorkbook = appSheets 'restores the default number of new sheets
Path = "C:\Temp\"
Filename = Dir(Path & "*.xls?") 'add the ? to pick up *.xlsx and *.xlsm files
Do While Filename <> ""
srcFile = Path & Filename
Workbooks.Open Filename:=srcFile, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
'--- potentially check for blank sheets, or only sheets
' with specific data on them
If Not IsSheetEmpty(Sheet) Then
Sheet.Copy After:=newBook.Sheets(1)
End If
Next Sheet
Workbooks(Filename).Close (False) 'add False to close without saving
Kill srcFile 'deletes the file
Filename = Dir()
Loop
'--- delete the original empty worksheet and save the book
newBook.Sheets(1).Delete
newBook.Save
newBook.Close
Application.ScreenUpdating = True 're-enable screen updates
End Sub
Internal sheet-to-sheet references within a workbook (Book1.xlsx) generally look like this:
=ABC!B23
But if you copy the worksheet with that reference to a new workbook, Excel will change it to an external reference back to the original workbook:
='[Book1.xlsx]ABC'!B23
There are several restrictions you'll have to place on references in your worksheets that you're copying into the single new workbook:
All sheet names in the destination workbook MUST be unique
Sheets named "ABC" in Book1 and "ABC" in Book2 would cause reference collisions in the destination workbook
One of the sheets must be renamed into a unique string
Sheet-to-sheet references that are completely internal to a workbook can be converted into similar references in the destination. References to external worksheets (in a different workbook) may be problematic and could require lots of additional logic to handle.
One option is to perform a wildcard search and replace on a worksheet after the Sheet.Copy is performed. The requirement here is that any sheet that is referenced must already be local to the new sheet in the destination book. (Otherwise, the "fixed-up" reference will still give you a #REF error.)
Sub test()
Dim area As Range
Dim farea As Range
'--- determines the entire used area of the worksheet
Set area = Range("A1").Resize(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
'--- replaces all external references to make them internal references
area.Replace What:="[*]", Replacement:=""
End Sub
The other option is much cleaner and a neat trick. When you're copying worksheets into a new workbook, if you copy ALL the sheets in a single action then Excel preserves the sheet-to-sheet references as internal (and doesn't replace each reference with a filename prefix) because it knows that the sheet references will be there in the new workbook. Here's that solution in your code:
Option Explicit
Function IsSheetEmpty(sht As Worksheet) As Boolean
IsSheetEmpty = Application.WorksheetFunction.CountA(sht.Cells) = 0
End Function
Sub GetSheets()
Dim i As Integer
Dim Path, Filename As String
Dim sh As Worksheet
Dim newBook As Workbook
Dim appSheets As Integer
Dim srcFile As String
Dim dstFile As String
Dim dstPath As String
Dim wasntAlreadyOpen As Boolean
Dim name As Variant
Dim allSheetNames As Dictionary 'check VBA Editor->Tools->References->Microsoft Scripting Runtime
Dim newSheetNames As Dictionary
Dim newNames() As String
Application.ScreenUpdating = False 'go faster by not waiting for display
'--- create a new workbook with only one worksheet
dstFile = "AllSheetsHere.xlsx"
dstPath = ActiveWorkbook.Path & "\" & dstFile
wasntAlreadyOpen = True
If Dir(dstPath) = "" Then
'--- the destination workbook does not (yet) exist, so create it
appSheets = Application.SheetsInNewWorkbook 'saves the default number of new sheets
Application.SheetsInNewWorkbook = 1 'force only one new sheet
Set newBook = Application.Workbooks.Add
newBook.SaveAs dstPath
Application.SheetsInNewWorkbook = appSheets 'restores the default number of new sheets
Else
'--- the destination workbook exists, so ...
On Error Resume Next
wasntAlreadyOpen = False
Set newBook = Workbooks(dstFile) 'connect if already open
If newBook Is Nothing Then
Set newBook = Workbooks.Open(dstPath) 'open if needed
wasntAlreadyOpen = True
End If
On Error GoTo 0
'--- make sure to delete any/all worksheets so we're only left
' with a single empty sheet named "Sheet1"
Application.DisplayAlerts = False 'we dont need to see the warning message
Do While newBook.Sheets.Count > 1
newBook.Sheets(newBook.Sheets.Count).Delete
Loop
newBook.Sheets(1).name = "Sheet1"
newBook.Sheets(1).Cells.ClearContents
newBook.Sheets(1).Cells.ClearFormats
Application.DisplayAlerts = True 'turn alerts back on
End If
'--- create the collections of sheet names...
' we need to make sure that all of the sheets added to the newBook have unique
' names so that any formula references between sheets will work properly
' LIMITATION: this assumes sheet-to-sheet references only exist internal to
' a single workbook. External references to sheets outside of the
' source workbook are unsupported in this fix-up
Set allSheetNames = New Dictionary
allSheetNames.Add "Sheet1", 1
Path = "C:\Temp\"
Filename = Dir(Path & "*.xls?") 'add the ? to pick up *.xlsx and *.xlsm files
Do While Filename <> ""
srcFile = Path & Filename
Workbooks.Open Filename:=srcFile, ReadOnly:=True
'--- first make sure all the sheet names are unique in the destination book
Set newSheetNames = New Dictionary
For Each sh In ActiveWorkbook.Sheets
If Not IsSheetEmpty(sh) Then
'--- loop until we get a unique name
i = 0
Do While allSheetNames.Exists(sh.name)
sh.name = sh.name & "_" & i 'rename until unique
i = i + 1
Loop
allSheetNames.Add sh.name, i
newSheetNames.Add sh.name, i
End If
Next sh
'--- we're going to copy ALL of the non-empty sheets to the new workbook with
' a single statement. the advantage of this method is that all sheet-to-sheet
' references are preserved between the sheets in the new workbook WITHOUT
' those references changed into external references
ReDim newNames(0 To newSheetNames.Count - 1)
i = 0
For Each name In newSheetNames.Keys
newNames(i) = name
i = i + 1
Next name
ActiveWorkbook.Sheets(newNames).Copy After:=newBook.Sheets(1)
Workbooks(Filename).Close (False) 'add False to close without saving
Kill srcFile 'deletes the file
'--- get the next file that matches
Filename = Dir()
Loop
'--- delete the original empty worksheet and save the book
If newBook.Sheets.Count > 1 Then
newBook.Sheets(1).Delete
End If
newBook.Save
'--- leave it open if it was already open when we started
If wasntAlreadyOpen Then
newBook.Close
End If
Application.ScreenUpdating = True 're-enable screen updates
End Sub
If you still have reference in your workbook to the cells being referenced (and from your example, you do), and if all of your #REF! errors used to point to a single sheet, there is an easy fix.
CTRL+H brings up the REPLACE function.
Simply enter #REF! in the "find" box, and Sheet1 in the "replace" box, and all references will now point to sheet1 in the same summary.xls workbook.
I've added a further workbook containig the referencins formulas. This one is closed during the whole procedure of deleting and summarizing the worksheets. The new workbook opens after this, therefore the referencing mistake is avoided.
Need help with a macro that will open 5 different csv files and automatically auto copy paste 3 columns of data (starting from the 2nd row to about the 200th row). Then the data will be pasted into one worksheet that is open so each file is all on one row (side by side)...any help will be appreciated..
Sub Macro2()
'Assign variable name to Target workbook
Var1 = ActiveWorkbook.Name
'Assign variable name to Target range
Var1R = "H1"
'Open Source WorkBook
Application.Workbooks.Open ("C:\MY DOCUMENTS\WORKBOOK(B).xls")
'Assign variable name to Source workbook
Var2 = ActiveWorkbook.Name
Var2R = "WORKSHEET-1"
'Copy from Source to Target
Sheets(Var2R).Columns("F").EntireColumn.Copy _
Destination:=Workbooks(Var1).Sheets("Sheet1").Range(Var1R)
'Close Source WorkBook wo/Save
Workbooks(Var2).Close False
End Sub
Here is a program that will do that. Obviously you'll have to modify the file-paths and ranges.
Sub copy_paste()
Dim filepaths
Dim twb As Workbook
Dim x As Long
Set twb = ThisWorkbook
filepaths = Array("C:\A.csv", "C:\B.csv", "C:\C.csv", "C:\D.csv", "C:\E.csv")
For x = 1 To UBound(filepaths)+1
With Workbooks.Open(filepaths(x-1))
.Sheets(1).Range("A2:C200").Copy twb.Sheets(1).Cells(2, 3 * x - 2)
.Close False
End With
Next x
End Sub