Access 2007 vba to find last row in Excel 2007 worksheet - excel

I have some VBA code within an Access 2007 database that exports data to an Excel 2007 file. I have a problem with this piece of the code:
Sub GetLastRow(strSheet, strColum)
Dim MyRange As Range
Dim lngLastRow As Long
Set MyRange = Worksheets(strSheet).Range(strColum & "1")
lngLastRow = Cells(65536, MyRange.Column).End(xlUp).Row
lngLastRow = lngLastRow + 1
Rows(lngLastRow & ":1048576").Select
Selection.Delete Shift:=xlUp
End Sub
The issue is the variable lngLastRow does not count belong the header rows (these are already in the excel file) in excel file unless I manually open the Excel session and then continue running the code. I would like to solve this correctly, but as a minimum if I could include some code to display the excel file so it appears automatically that would solve the issue anyway. But can't see where/how I could do this.
The following is the function that calls the above function.
Function CreateExcelData()
'Copies data to be exported to an Excel workbook
Dim objExcel As Excel.Application
Dim strTemplate As String
Dim strPathFile As String
Dim RowCount As Integer
Dim wbExported As Workbook 'The initial exported data
Dim wbAllData As Workbook 'Workbook to copy exported data to
Dim rngUsed As Range 'Used range in exported data
Dim Sheet As Worksheet
'Try GetObject first in case Excel Application is already open.
On Error Resume Next
Set objExcel = GetObject(, "excel.Application")
If Err.Number <> 0 Then
'GetObject returns error if not already open
'so use CreateObject
On Error GoTo 0 'Turnoff ASAP so error trapping is available
Set objExcel = CreateObject("Excel.Application")
End If
strTemplate = "TEMPLATE.xlsm"
strPathFile = strPath & strTemplate
strPathFileFinal = strPath & strReportName & "_" & Mydat & ".xlsm"
FileCopy strPathFile, strPathFileFinal
'Open the exported data workbook and assign to a variable
Set wbExported = objExcel.Workbooks.Open(strFilePath)
'Open the data workbook to receive the exported data and assign to a variable.
Set wbAllData = objExcel.Workbooks.Open(strPathFileFinal)
'Exported data
With wbExported.Sheets(1).UsedRange
Set rngUsed = .Offset(1, 0) _
.Resize(.Rows.Count - 1, .Columns.Count)
End With
With wbAllData.Sheets("MainSheet")
'Copy exported data and paste to first empty cell of MainSheet in File
rngUsed.Copy
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Call GetLastRow("MainSheet", "A")
wbExported.Close
wbAllData.Save
wbAllData.Close
Set rngUsed = Nothing
Set wbExported = Nothing
Set wbAllData = Nothing
Set objExcel = Nothing
Kill strFilePath
End Function

Your code has a number of unqualified and partially qualified references to Worksheets and Ranges. These will refer to the ActiveWorkbook or ActiveSheet, probably not wjhat you want, and will cause unpredictable results.
Try this refactor
Sub GetLastRow(MyRange As Excel.Range)
Dim lngLastRow As Long
With MyRange.Worksheet
lngLastRow = .Cells(.Rows.Count, MyRange.Column).End(xlUp).Row
.Range(.Cells(lngLastRow + 1, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
End With
End Sub
Call it like this
GetLastRow wbAllData.Worksheets("MainSheet").Columns("A")

Related

Consolidate all Excel tabs in workbook into minimum tabs on another workbook

I have 200 sheets in 1 workbook with an average of 65,000 records on each sheet. I am trying to build a macro that merges all sheets in 1 Excel file into the minimum number of sheets on a NEW Excel file. As Excel has a limitation of 1.xxx million records, the new file would have to have more than 1 sheet, but I am looking to consolidate as much as possible on the new file/tabs.
Below is what I have built so far, but I am struggling to even copy and past the data properly, let alone adding new sheets whenever needed.
Is anyone able to assist?
Sub Combine()
Dim J As Integer
Dim s As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Sheets(1).Select
'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set INITIALFILE = ActiveWorkbook
' copy headings
Sheets(1).Activate
Range("A1").EntireRow.Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial
INITIALFILE.Activate
For Each s In ActiveWorkbook.Sheets
If s.Name <> "Combined" Then
Application.GoTo Sheets(s.Name).[a1]
Selection.CurrentRegion.Select
' Don't copy the headings
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy
wb.Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A" & Sheets(1).Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
INITIALFILE.Activate
End If
Next
End Sub
If you use Range object variables, you rarely need to use Select and your screen will be much the quieter. As noted using a general On Error Resume Next will make it almost impossible to make your code work properly as you will not see useful error messages.
Sub Combine()
Dim NewFile As Workbook
Dim InitialFile As Workbook
Const RowLimit As Long = 1000000
Dim strFile As String
Dim InRows As Long
Dim OutRows As Long
Dim FirstSheet As Worksheet
Dim OutSheet As Worksheet
Dim ASheet As Worksheet
Dim CopySet As Range
Dim OutLoc As Range
Dim Anon As Variant
Set NewFile = ActiveWorkbook
Set FirstSheet = NewFile.Sheets.Add(After:=Sheets(Sheets.Count))
Set OutSheet = FirstSheet
Set OutLoc = OutSheet.Range("A1")
'Opens initial file
strFile = Application.GetOpenFilename
Workbooks.Open strFile
Set InitialFile = ActiveWorkbook
OutSheet.Activate
For Each ASheet In InitialFile.Sheets
Anon = DoEvents()
If ASheet.Name <> "Combined" Then
Set CopySet = ASheet.Cells.SpecialCells(xlCellTypeLastCell)
If CopySet.Row + OutLoc.Row > RowLimit Then
Set OutSheet = NewFile.Sheets.Add(After:=OutSheet)
Set OutLoc = OutSheet.Range("A1")
End If
' Only copy the headings if needed
If OutLoc.Row = 1 Then
Set CopySet = Range(ASheet.Range("A1"), CopySet)
Else
Set CopySet = Range(ASheet.Range("A2"), CopySet)
End If
CopySet.Copy OutLoc
Set OutLoc = OutLoc.Offset(CopySet.Rows.Count, 0)
End If
Next ASheet
FirstSheet.Activate
End Sub
The call to DoEvents() is there to keep the screen current rather than frozen in some half-drawn fashion.

Applying code to active workbook from another workbook error: No such a interface supported

I want below code to open a closed workbook and copy the values from the range StartRow and EndRow to active workbook.
I get
error 1004 "No such interface supported".
on line "xlBook.Sheets(ShName).Range(Cells(StartRow, 1), Cells(EndRow, 1)).Select"
When I run this code directly in the workbook I want to copy the data from, it works.
Sub GetDataFromClosedBook()
'copy data from closed workbook to active workbook
Dim xlApp As Application
Dim xlBook As Workbook
Dim sh As Object
Set xlApp = CreateObject("Excel.Application")
'Path source Wokrbook
Set xlBook = xlApp.Workbooks.Open("C:\Users\name\Desktop\EXCEL USEFUL DOSC\Missing Data Check New Process\Missing Data Reports\" & Sheets("Data Check").Range("C3").Value & ".xlsx")
xlApp.Visible = True
ShName = Sheets("Data Check").Range("C3").Value
With xlBook.Sheets(ShName)
StartRow = .Range("E:E").Find(what:="January-2020", after:=.Range("E1")).Row
EndRow = .Range("E:E").Find(what:="January-2020", after:=.Range("E1"), searchdirection:=xlPrevious).Row
'ThisWorkbook.Activate
xlBook.Sheets(ShName).Range("A2").Value = ShName
xlBook.Sheets(ShName).Range(Cells(StartRow, 1), Cells(EndRow, 1)).Select
'Sheets(ShName).Range(Cells(StartRow, 1), Cells(EndRow, 1)).Select
End With
xlApp.DisplayAlerts = False
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Set xlBook = ActiveWorkbook
Set sh = Sheets("Dealer_ID Check")
sh.Activate
Range("A1").Select
sh.Paste
End Sub
Putting all the comments together, your code so far could be refactoed as
Option Explicit
Sub GetDataFromClosedBook()
'copy data from closed workbook to active workbook
Dim wbData As Workbook
Dim wbDest As Workbook
Dim wsDataCheck As Worksheet
Dim wsDealerIDCheck As Worksheet
Dim wsReports As Worksheet
Dim ShName As String
Dim PthName As String
Dim FlName As String
Dim rStartRow As Range, rEndRow As Range
Dim rng As Range
Set wbDest = ActiveWorkbook ' not prefered, better to be explicit
Set wsDataCheck = wbDest.Worksheets("Data Check")
'Path source Wokrbook
PthName = "C:\Users\name\Desktop\EXCEL USEFUL DOSC\Missing Data Check New Process\Missing Data Reports\"
FlName = wsDataCheck.Range("C3").Value
ShName = wsDataCheck.Range("C3").Value
On Error Resume Next
Set wbData = Workbooks.Open(PthName & FlName & ".xlsx")
On Error GoTo 0
If wbData Is Nothing Then
' File didn't open
Exit Sub
End If
Set wsReports = Nothing
On Error Resume Next
Set wsReports = wbData.Worksheets(ShName)
On Error GoTo 0
If wsReports Is Nothing Then
' No such sheet
GoTo CleanUp
End If
With wsReports
Set rStartRow = .Range("E:E").Find(What:="January-2020", After:=.Range("E1"), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
Set rEndRow = .Range("E:E").Find(What:="January-2020", After:=.Range("E1"), SearchDirection:=xlPrevious)
If rStartRow Is Nothing Or rEndRow Is Nothing Then
' Search term not found, What Now?
GoTo CleanUp
End If
.Range("A2").Value = ShName
Set rng = .Range(rStartRow, rEndRow)
' For debug purposes only
.Activate ' the worksheet
rng.Select ' the range
End With
Application.DisplayAlerts = False
' do you want to save the change you made to wbData?
wbData.Close True ' or wbData.Save False
Set wsDealerIDCheck = wbDest.Worksheets("Dealer_ID Check")
' continue ...
Exit Sub
CleanUp:
If Not wbData Is Nothing Then wbData.Close False
End Sub
The comments have pointed out the disassociation in your code many times. Your code uses implicit and explicit references to worksheets without performing any of the necessary checks to prevent errors.
The commenters we're being polite and didn't use strong terms, but I am not polite: ActiveSheet is not what you think it is.
What you think ActiveSheet is during design is practically never guaranteed to be ActiveSheet during run time. There are certainly times when they are but such certainties are rare unless you make the effort to code then into reality. All other times you should explicitly reference your ranges. Consider it a life saving skill
Let's assume you set a pointer to a workbook and you open it, whatever sheet it opens to becomes the ActiveSheet. Typically this is the sheet that was last viewed when the workbook was saved, but that is by no means guaranteed.
What is even less guaranteed, is your assumption that it will open to the "Data Check" sheet.
You can read from and write to the "Data Check" sheet all day long without caring if it is the ActiveSheet or not, but you can only Select a cell on it when it is the ActiveSheet.
The worksheet variableShName is set to the "Data Check" worksheet. At no point have you validated ShName as the ActiveSheet, but ShName must be the ActiveSheet to prevent an error on this line:
xlBook.Sheets(ShName).Range(Cells(StartRow, 1), Cells(EndRow, 1)).Select
So I had this error in word but as was pointed out "ActiveDocument" was the issue even though I only had one word application open. By changing to wdApp.ActiveDocument it resolved it. wdApp being my word.application object.

VBA - Copy-Paste to another workbook

I am trying to copy specific cells from one workbook to another at the end of the table.
I assume the problem is with using 'ActiveWorkbook' a lot.
I get the error "Object doesnt support this property or method" and it seems that macro copies cells from CurrentBook and not uploader.
How can I fix my code?
Dim uploadfile As Variant
Dim uploader As Workbook
Dim CurrentBook As Workbook
Dim lastRow As Integer
Set CurrentBook = ActiveWorkbook
uploadfile = Application.GetOpenFilename()
If uploadfile = "False" Then
Exit Sub
End If
Workbooks.Open uploadfile
Set uploader = ActiveWorkbook
With uploader
Application.CutCopyMode = False
Range("A1:J100").Copy
End With
CurrentBook.Activate
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastRow & ":J" & lastRow + 100).Select
Selection.Paste
uploader.Close
End Sub
In VBA you must not use Ative.
So replace all the Active and you have to use PasteSpecial, it's better than Paste
Sub test()
Dim uploadfile As Variant
Dim uploader As Workbook
Dim CurrentBook As Workbook
Dim lastRow As Integer
Set CurrentBook = ThisWorkbook
uploadfile = Application.GetOpenFilename()
If uploadfile = "False" Then
Exit Sub
End If
Set uploader = Workbooks.Open(uploadfile)
Application.CutCopyMode = False
uploader.Worksheets(1).Range("A1:J100").Copy
lastRow = CurrentBook.Worksheets(1).Cells(CurrentBook.Worksheets(1).Rows.Count, "A").End(xlUp).Row + 1
Range("A" & lastRow & ":J" & (lastRow + 100)).PasteSpecial xlPasteValues
uploader.Close
End Sub
This code works for me,
Your welcome :)
Here, and only because I'm bored at work, the are thousands of posts like this:
Option Explicit
Sub CopyPaste()
Dim uploadfile As String 'not Variant, the filename will be a string
Dim wbCopy As Workbook 'Better than uploader As Workbook you need to declare variables easy to read
Dim wbPaste As Workbook 'same as above
Dim LastRow As Lon 'integer doesn't work (it will be a long delimited to integer) either Byte(0-255) or Long
Set wbPaste = ThisWorkbook 'the workbook containing the code
uploadfile = Application.GetOpenFilename()
If uploadfile = "False" Then
Exit Sub
End If
Set wbCopy = Workbooks.Open(uploadfile) 'declare your paste workbook like this
' Set uploader = ActiveWorkbook this way of referencing a workbook might give you errors, use the above
With wbCopy.Sheets("MySheetName") 'reference always the worksheets, change MySheetName for the actual sheet name
'Application.CutCopyMode = False this is useless here it's emptying the clipboard but below you copy something new
.Range("A1:J100").Copy 'you missed the . on the beginning (when using With you need to use the dot to reference the with)
End With
With wbPaste.Sheets("MySheetName") 'reference always the worksheets, change MySheetName for the actual sheet name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow).PasteSpecial xlPasteValues 'when you copy/paste you just need to find the first cell on the paste range, Excel will paste the whole range
End With
Application.CutCopyMode = False 'now you can use this to avoid warning message on closing the copy workbook
wbCopy.Close Savechanges:=False
End Sub
Below you could find a sample code on how to copy from one workbook to another:
Option Explicit
Sub test()
Dim wbSource As Workbook, wbDestination As Workbook
'Set both workbooks by name to avoid conflicts
Set wbSource = Workbooks("Book1")
Set wbDestination = Workbooks("Book2")
'Copy paste only values
wbSource.Worksheets("Sheet1").Range("A1").Copy
wbDestination.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues
End Sub

Copy two sheets into new workbook as values, then save with todays date and close workbook

When using all the different examples that I've found on stackoverflow they give me a complex task that still requires a mouse click to confirm its ok to paste the data. I also am struggling to get the whole thing to operate in one section of VBA code.
Public Sub copySheets()
Dim wkb As Excel.Workbook
Dim newWkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim newWks As Excel.Worksheet
Dim sheets As Variant
Dim varName As Variant
'------------------------------------------------------------
'Define the names of worksheets to be copied.
sheets = VBA.Array("Analysis - London", "London - Commercial")
'Create reference to the current Excel workbook and to the destination workbook.
Set wkb = Excel.ThisWorkbook
Set newWkb = Excel.Workbooks.Add
For Each varName In sheets
'Clear reference to the [wks] variable.
Set wks = Nothing
'Check if there is a worksheet with such name.
On Error Resume Next
Set wks = wkb.Worksheets(VBA.CStr(varName))
On Error GoTo 0
'If worksheet with such name is not found, those instructions are skipped.
If Not wks Is Nothing Then
'Copy this worksheet to a new workbook.
Call wks.Copy(newWkb.Worksheets(1))
'Get the reference to the copy of this worksheet and paste
'all its content as values.
Set newWks = newWkb.Worksheets(wks.Name)
With newWks
Call .Cells.Copy
Call .Range("A1").PasteSpecial(Paste:=xlValues)
End With
End If
Next
ActiveWorkbook.SaveCopyAs Filename:=("C:\Users\\My stuff\Forecast" & Format(Now(), "YYYYMMDD") & " Forecasting" & ".xlsm")
Thanks
Replace
With newWks
Call .Cells.Copy
Call .Range("A1").PasteSpecial(Paste:=xlValues)
End With
With
Dim c as range
For each c in newwks.usedrange
c.formula = c.value
next c

Copy data from one workbook to another "Object Required"

I'm currently doing VBA project which need to copy from a workbook to another, which the WBookPst is the workbook I firstly open (use) meanwhile WBookCopy is the workbook where I open based on the links where I got by listing all ".xslt" format in a File into my Sheet1 of my first workbook. Here is my code :
Sub SortFiles()
'Set up your variables and turn off screen updating.
'Dim iCounter As Integer
Application.ScreenUpdating = False
'Sort the rows based on the data in column C
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim filePath As String
Dim sheetName As String
Dim sheetCopy As Worksheet
Dim sheetPate As Worksheet
Dim rngCopy As Range
Dim rngPst As Range
filePath = Range("B2").Value
Set WBookCopy = Workbooks.Open(filePath)
Columns(30).Insert
For i = 1 To Sheets.count
Cells(i, 30) = Sheets(i).Name
Next i
sheetName = Range("AD1").Value
Set sheetCopy = WBookCopy.Worksheets(sheetName)
Set rngCopy = sheetCopy.Range("A:AA").Copy
Set WBookPst = ThisWorkbook
Set sheetPaste = WBookPst.Worksheets("Sheet1").Activate
Set rngCopy = sheetPaste.Range("A:AA").Select
ActiveSheet.Paste
End Sub
At Set rngCopy = sheetCopy.Range("A:AA").Copy there's error "Objects required".
What does that mean?
By the way, is how I copy and paste the data between sheets correct?
The issue is that rngCopy is of type range and you can't set it equal to a method (copy). Remove the .Copy and you should be fine. You also don't need to set the worksheet out range to a variable. You could just do one line that says WBookCopy.SheetName.Range("A:AA").Copyand then another line to paste.
As #Wyatt mentioned - your copy\paste syntax is incorrect
Here are 2 ways to do it:
Worksheets("Sheet1").Range("A:AA").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
or
Worksheets("Sheet1").Range("A:AA").Copy Destination:=Worksheets("Sheet2").Range("A1")

Resources