I recently split my code into two sections to stop the date automatically being entered, as on a Monday, we need to do 3 days worth of data
All I did was Add a new sub and redefine the variables - now i can't delete a named range
My code:
Option Explicit
Sub Import()
Dim ws As Worksheet, lastRowC As Long
Set ws = Worksheets("Report")
lastRowC = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row + 1 ' bottom populated cell of Column "C", plus 1
With ws.QueryTables.Add(Connection:= _
"TEXT;N:\Operations\001 Daily Management\Cemex\FMSQRY.CSV", Destination:= _
ws.Cells(lastRowC, 3))
.Name = "FMSQRY"
' etc
' etc
.Refresh BackgroundQuery:=False
End With
With ActiveWorkbook
.Connections("FMSQRY").Delete
.Names("FMSQRY").Delete
End With
End Sub
Sub TodaysDate()
Dim ws As Worksheet, lastRowC As Long, lastRowH As Long
Set ws = Worksheets("Report")
lastRowH = ws.Cells(ws.Rows.Count, 8).End(xlUp).Row + 1 ' bottom populated cell of Column "H", plus 1
lastRowC = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row ' bottom populated cell of Column "C"
With ws.Range(ws.Cells(lastRowH, 8), ws.Cells(lastRowC, 8))
.FormulaR1C1 = "=TODAY()"
.Value = .Value
End With
End Sub
So nothing to do with the Named Range was actually touched
.Name = "FMSQRY" still names my range, but when .Names("FMSQRY").Delete comes around I get a 1004 Error
ANSWER:
With ActiveWorkbook
.Connections("FMSQRY").Delete
With ws
.Names("FMSQRY").Delete
End With
End With
Your Name is on sheet-level and not Workbook-level.(you could have the same name on different sheets)
so:
ActiveWorkbook.Worksheets("Report").Names("FMSQRY").Delete
I am not sure why that code doesn't work.
But if you write code like below then it works...
Dim nm As Name
For Each nm In ActiveWorkbook.Names
If nm.Name = "FMSQRY" Then nm.Delete
Next nm
Try the below code without the .connections:
Option Explicit
Sub test()
With ThisWorkbook
.Names("FMSQRY").Delete
End With
End Sub
Related
I have created a spreadsheet with a sheet 1 input table, and want to transfer/copy that data into a sheet 2 log table. The input table on sheet 1 will have an inspection date and an inspection name cells. What I am having an issue with is that I can get the first line of the log to input, but the 2nd line I get a "Run0time error '1004': Application-defined or object defined error". Not sure what to look at from here.
Here's my code (I know, it's stiff rough and needs to be cleaned up):
Private Sub Add_Click()
Dim InspectionDate As String, InspectionName As String
Dim LastRow As Long
Worksheets("sheet1").Select
InspectionDate = Range("B4")
InspectionName = Range("B5")
Worksheets("sheet2").Select
Worksheets("sheet2").Range("B3").Select
If Worksheets("sheet2").Range("B3").Offset(1, 0) <> "" Then
Worksheets("sheet2").Range("B3").End(x1Down).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = InspectionDate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = InspectionName
Worksheets("sheet1").Select
Worksheets("sheet1").Range("B4:B5").ClearContents
End Sub
Two main reasons why .Select, .Activate, Selection, Activecell, Activesheet, Activeworkbook, etc. should be avoided
The reasons are explained in the second answer on that page.
I have tested the code below and it works for me.
I'm autistic; so sometimes I appear to school others, when I'm only trying to help.
Option Explicit
Private Sub Add_Click()
Dim InspectionDate$, InspectionName$
Dim LastRow&
Dim WS As Worksheet, WS2 As Worksheet
Set WS = Worksheets("sheet1")
Set WS2 = Worksheets("sheet2")
InspectionDate = WS.Range("B4")
InspectionName = WS.Range("B5")
LastRow = 3
If WS2.Range("B" & LastRow + 1) <> "" Then
LastRow = WS2.Range("B" & Rows.count - 1).End(xlUp).Row
End If
WS2.Cells(LastRow + 1, 2) = InspectionDate
WS2.Cells(LastRow + 1, 3) = InspectionName
WS.Range("B4:B5").ClearContents
End Sub
EDIT: I've pasted some revised code below in the Sub(Copyinternal) section. Still doesn't work but maybe I'm on the right track?
I have a workbook with 6 tabs. Sheets are set up as follows:
Controls
Forecast
Financial Update
Board Goals
Internal Calendar
External Calendar
Sheets 2-4 contain data tables that I would like to filter in two different ways and copy/paste to both tabs 5 & 6 without overwriting.
Sheets 5 & 6 have headers in row 1 that I would like to maintain.
Trying to:
First delete any existing information in "Internal Calendar" sheet and "External Calendar" sheet from Row 2 down without deleting the headers.
In "Forecast" sheet, filter column H on selections "Both" and "Internal" in and then copy/paste that information into "Internal Calendar" sheet starting in column C. I'm then trying to do the same for "Financial Update" and "Board Goals" sheets, but Copy/Pasting the filtered information after the content that's already been pasted into "Internal Calendar", as to not overwrite information.
Repeat step 2 except Filter H on "Both" and "External" and Copy/Paste the filtered info into "External Calendar" starting in column C.
Controls sheet can be ignored.
Loop begins to run correctly only if I run the macro while my active sheet is "Forecast", but then it stops after pasting that data and doesn't move onto the following two sheets. I'm also not entirely sure the existing code I have will identify the first empty row to append data to in the destination sheets.
I'm pretty new to using VBA, so a guide in the right direction would be very appreciated.
Sub CalendarAutomation()
ClearSheets
CopyInternal
CopyExternal
End Sub
Sub ClearSheets()
'Clear out Contents
Sheets("Internal Calendar").Select
activesheet.Range("C2:G250").Select
Selection.ClearContents
Sheets("External Calendar").Select
Range("C2:G250").Select
Selection.ClearContents
End Sub
Sub CopyInternal()
Dim ws As Variant
Dim starting_ws As Worksheet
Dim ending_ws As Worksheet
Dim rng As range
Set starting_ws = ThisWorkbook.Worksheets("Forecast")
Set ending_ws = ThisWorkbook.Worksheets("Internal Calendar")
Set rng = ActiveRange
For ws = 2 To 4
If Selection.AutoFilter = OFF Then Selection.AutoFilter
ws.rng.AutoFilter Field:=6, Criteria1:="=Both", _
Operator:=xlOr, Criteria2:="=Internal"
UsedRange.Copy
ending_ws.range(Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row).Paste
Next ws
End Sub
Sub CopyExternal()
Dim ws As Worksheet
Dim unusedRow As Long
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Controls" _
And Not ws.Name = "Internal Calendar" _
And Not ws.Name = "External Calendar" Then
Range("$C$3:$H$14").AutoFilter Field:=6, Criteria1:="=Both", _
Operator:=xlOr, Criteria2:="=External"
Range("C4:G14").Select
Selection.Copy
Sheets("External Calendar").Select
activesheet.Paste
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
End If
Next ws
End Sub
Try this:
Sub tst()
Dim ctrl As Worksheet: Set ctrl = ThisWorkbook.Sheets("Controls")
Dim fcast As Worksheet: Set fcast = ThisWorkbook.Sheets("Forecast")
Dim fu As Worksheet: Set fu = ThisWorkbook.Sheets("Financial Update")
Dim bg As Worksheet: Set bg = ThisWorkbook.Sheets("Board Goals")
Dim ic As Worksheet: Set ic = ThisWorkbook.Sheets("Internal Calendar")
Dim ec As Worksheet: Set ec = ThisWorkbook.Sheets("External Calendar")
Dim ic_last_r As Long
Dim ec_last_r As Long
ic_last_r = ic.Cells(ic.Rows.Count, 3).End(xlUp).Row
ec_last_r = ec.Cells(ec.Rows.Count, 3).End(xlUp).Row
If ic_last_r < 2 Then ic_last_r = 2 'avoid deleting 1st row
If ec_last_r < 2 Then ec_last_r = 2
ic.Rows("2:" & ic_last_r).ClearContents
ec.Rows("2:" & ec_last_r).ClearContents
copy_paste fcast, ic, "Both", "Internal", Array("Controls", "Forecast", "External Calendar")
copy_paste fcast, ec, "Both", "External", Array("Controls", "Forecast", "Internal Calendar")
End Sub
Sub copy_paste(ws1 As Worksheet, ws2 As Worksheet, c1 As String, c2 As String, wsheets)
Dim ws As Worksheet
Dim ws2_last_r As Long
For Each ws In ThisWorkbook.Worksheets
For i = LBound(wsheets) To UBound(wsheets)
If ws.Name = wsheets(i) Then GoTo n_ext
Next
ws2_last_r = ws2.Cells(ws2.Rows.Count, 3).End(xlUp).Row
ws1.Range("A1").AutoFilter 8, c1, xlOr, c2
ws1.Range("A1").CurrentRegion.Columns("C:G").Copy
ws2.Range("C" & ws2_last_r).PasteSpecial xlPasteAll
ws1.Range("A1").AutoFilter
n_ext:
Next
End Sub
Your code after changes (I hope it will work for you but there is a space for improvement):
Sub CalendarAutomation()
ClearSheets
CopyInternal
CopyExternal
End Sub
Sub ClearSheets()
'Clear out Contents
Sheets("Internal Calendar").Range("C2:G250").ClearContents
Sheets("External Calendar").Range("C2:G250").ClearContents
End Sub
Sub CopyInternal()
Dim ws As Variant
Dim starting_ws As Worksheet
Dim ending_ws As Worksheet
Dim rng As Range
Set starting_ws = ThisWorkbook.Worksheets("Forecast")
Set ending_ws = ThisWorkbook.Worksheets("Internal Calendar")
For ws = 2 To 4
If Sheets(ws).AutoFilterMode Then Sheets(ws).Range("A1").AutoFilter
Sheets(ws).Range("A1").AutoFilter 6, "Both", xlOr, "Internal"
Sheets(ws).UsedRange.Copy
ending_ws.Cells(ending_ws.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row, 3).PasteSpecial xlPasteAll 'pasting into "C" column
Next ws
End Sub
Sub CopyExternal()
Dim ws As Worksheet
Dim unusedRow As Long
Dim external As Worksheet: Set external = ThisWorkbook.Worksheets("External Calendar")
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Controls" _
And Not ws.Name = "Internal Calendar" _
And Not ws.Name = "External Calendar" Then
unusedRow = external.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row 'if you want to find last filled row i suggest to change to: external.cells(external.rows.count, [column number]).end(xlup).row
ws.Range("A1").AutoFilter Field:=6, Criteria1:="=Both", _
Operator:=xlOr, Criteria2:="=External"
ws.UsedRange.Copy
external.Cells(unusedRow, 1).PasteSpecial xlPasteAll 'paste into "A" column
End If
Next ws
End Sub
Hi I could not find the answer to my question from searching.
I have multiple worksheets and would like to create a column at the very beginning with a fill-down type approach of a specific string.
For example,
If worksheet name contains "Zebra" - insert a new column at the very beginning and input "Zebra's" across all cells down up until the last data point on the adjacent column.
I need to do this for four different worksheets:
Zebra
Elephant
Rhino
Snake
Here is what I have thus far, I cannot get it to work:
Sub addAnimal()
Dim ws As Worksheet
Dim N As Long
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "zebra*" Then
Application.Goto ActiveWorkbook.Sheets(ws.Name).Cells(2, 1)
ActiveCell.EntireColumn.Insert
ActiveCell.Value = "Zebra"
Dim lastRow As Long, lastUsedRow As Long
Dim srcRange As Range, fillRange As Range
With Worksheets(ws.Name)
lastUsedRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
' Fill values from A:D all the way down to lastUsedRow
Set srcRange = .Range("A" & lastUsedRow)
Set fillRange = .Range("A" & lastRow)
fillRange.Value = srcRange.Value
End With
End If
Next ws
Due to the array of animals compared to the collection of worksheet names there is going to be some repetition but a helper sub procedure can eliminate much of it.
Option Explicit
Sub addAnimalMain()
Dim w As Long, grr As Variant
grr = Array("Zebra", "Elephant", "Rhino", "Snake")
For w = 1 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Worksheets(w)
Select Case True
Case CBool(InStr(1, .Name, grr(0), vbTextCompare))
addAnimalHelper ThisWorkbook.Worksheets(w), grr(0)
Case CBool(InStr(1, .Name, grr(1), vbTextCompare))
addAnimalHelper ThisWorkbook.Worksheets(w), grr(1)
Case CBool(InStr(1, .Name, grr(2), vbTextCompare))
addAnimalHelper ThisWorkbook.Worksheets(w), grr(2)
Case CBool(InStr(1, .Name, grr(3), vbTextCompare))
addAnimalHelper ThisWorkbook.Worksheets(w), grr(3)
End Select
End With
Next w
End Sub
Sub addAnimalHelper(ws As Worksheet, grrr As Variant)
With ws
.Columns(1).EntireColumn.Insert
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, -1)) = grrr
End With
End Sub
I have an excel workbook, in worksheet1 in Column A, IF the value of that column = ERR I want it to be deleted (the entire row), how is that possible?
PS: keep in mind that I have never used VBA or Macros before, so detailed description is much appreciated.
Using an autofilter either manually or with VBA (as below) is a very efficient way to remove rows
The code below
Works on the entire usedrange, ie will handle blanks
Can be readily adpated to other sheets by changing strSheets = Array(1, 4). ie this code currently runs on the first and fourth sheets
Option Explicit
Sub KillErr()
Dim ws As Worksheet
Dim lRow As Long
Dim lngCol As Long
Dim rng1 As Range
Dim strSheets()
Dim strws As Variant
strSheets = Array(1, 4)
For Each strws In strSheets
Set ws = Sheets(strws)
lRow = ws.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
lngCol = ws.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
Application.ScreenUpdating = False
ws.Rows(1).Insert
Set rng1 = ws.Range(ws.Cells(1, lngCol), ws.Cells(lRow + 1, lngCol))
With rng1.Offset(0, 1)
.FormulaR1C1 = "=RC1=""ERR"""
.AutoFilter Field:=1, Criteria1:="TRUE"
.EntireRow.Delete
On Error Resume Next
.EntireColumn.Delete
On Error GoTo 0
End With
Next
Application.ScreenUpdating = True
End Sub
sub delete_err_rows()
Dim Wbk as Excel.workbook 'create excel workbook object
Dim Wsh as worksheet ' create excel worksheet object
Dim Last_row as long
Dim i as long
Set Wbk = Thisworkbook ' im using thisworkbook, assuming current workbook
' if you want any other workbook just give the name
' in invited comma as "workbook_name"
Set Wsh ="sheetname" ' give the sheet name here
Wbk.Wsh.activate
' it means Thisworkbook.sheets("sheetname").activate
' here the sheetname of thisworkbook is activated
' or if you want looping between sheets use thisworkbook.sheets(i).activate
' put it in loop , to loop through the worksheets
' use thisworkbook.worksheets.count to find number of sheets in workbook
Last_row = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row 'to find the lastrow of the activated sheet
For i = lastrow To 1 step -1
if activesheet.cells(i,"A").value = "yourDesiredvalue"
activesheet.cells(i,"A").select ' select the row
selection.entirerow.delete ' now delete the entire row
end if
Next i
end sub
Note any operations that you do using activesheet , will be affected on the currently activated sheet
As your saying your a begginner, why dont you record a macro and check out, Thats the greatest way to automate your process by seeing the background code
Just find the macros tab on the sheet and click record new macro , then select any one of the row and do what you wanted to do , say deleting the entire row, just delete the entire row and now go back to macros tab and click stop recording .
Now click alt+F11 , this would take you to the VBA editor there you find some worksheets and modules in the vba project explorer field , if you dont find it search it using the view tab of the VBA editor, Now click on module1 and see the recorded macro , you will find something like these
selection.entirerow.delete
I hope i helped you a bit , and if you need any more help please let me know, Thanks
Fastest method:
Sub DeleteUsingAutoFilter()
Application.ScreenUpdating = False
With ActiveSheet
.AutoFilterMode = False
.Columns("A").AutoFilter Field:=1, Criteria1:="ERR"
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Second fastest method (lots of variations to this one too):
Sub DeleteWithFind()
Dim rFound As Range, rDelete As Range
Dim sAddress As String
Application.ScreenUpdating = False
With Columns("A")
Set rFound = .Find(What:="ERR", After:=.Resize(1, 1), SearchOrder:=xlByRows)
If Not rFound Is Nothing Then
Set rDelete = rFound
Do
Set rDelete = Union(rDelete, rFound)
Set rFound = .FindNext(rFound)
Loop While rFound.Row > rDelete.Row
End If
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub
Autofilter method for multiple sheets:
Sub DeleteUsingAutoFilter()
Dim vSheets As Variant
Dim wsLoop As Worksheet
Application.ScreenUpdating = False
'// Define worksheet names here
vSheets = Array("Sheet1", "Sheet2")
For Each wsLoop In Sheets(vSheets)
With wsLoop
.AutoFilterMode = False
.Columns("A").AutoFilter Field:=1, Criteria1:="ERR"
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Next wsLoop
Application.ScreenUpdating = True
End Sub
Assuming there are always values in the cells in column A and that the data is in the first sheet, then something like this should do what you want:
Sub deleteErrRows()
Dim rowIdx As Integer
rowIdx = 1
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
While ws.Cells(rowIdx, 1).Value <> ""
If ws.Cells(rowIdx, 1).Value = "ERR" Then
ws.Cells(rowIdx, 1).EntireRow.Delete
Else
rowIdx = rowIdx + 1
End If
Wend
End Sub
I have code to archive data from "sheet1" to "sheet2". It overwrites existing data in the "sheet2" rows from the previous archive exercise.
How do I have it seek the next blank row vs. overwriting existing data?
I have two header rows so it should commence with row 3.
Option Explicit
Sub Archive()
Dim lr As Long, I As Long, rowsArchived As Long
Dim unionRange As Range
Sheets("sheet1").Unprotect Password:="xxxxxx"
Application.ScreenUpdating = False
With Sheets("sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For I = 3 To lr 'sheets all have headers that are 2 rows
If .Range("AB" & I) = "No" Then
If (unionRange Is Nothing) Then
Set unionRange = .Range(I & ":" & I)
Else
Set unionRange = Union(unionRange, .Range(I & ":" & I))
End If
End If
Next I
End With
rowsArchived = 0
If (Not (unionRange Is Nothing)) Then
For I = 1 To unionRange.Areas.Count
rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count
Next I
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
unionRange.EntireRow.Delete
End If
Sheets("sheet2").Protect Password:="xxxxxx"
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Operation Completed. Total Rows Archived: " & rowsArchived
End Sub
Change
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
... to,
with worksheets("sheet2")
unionRange.Copy _
Destination:=.Cells(.rows.count, 1).end(xlup).offset(1, 0)
end with
This is like starting at the bottom row of the worksheet (e.g. A1048576) and tapping [ctrl+[↑] then selecting the cell directly below it.
The With ... End With statement isn't absolutely necessary but it shortens the code line enough to see it all without scolling across. unionRange has been definied by parent worksheet and cell range so there is no ambiguity here.
I'd propose the following "refactoring"
Option Explicit
Sub Archive()
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Sheets("sheet1")
Set sht2 = Sheets("sheet2")
sht1.Unprotect Password:="xxxxxx"
With sht1.Columns("AB").SpecialCells(xlCellTypeConstants).Offset(, 1) '<== change the offset as per your need to point to whatever free column you may have
.FormulaR1C1 = "=if(RC[-1]=""NO"","""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
.EntireRow.Copy Destination:=sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1, 0)
MsgBox "Operation Completed. Total Rows Archived: " & .Cells.Count
End With
.ClearContents
End With
sht2.Protect Password:="xxxxxx"
End Sub
just choose a "free" column in "Sheet1" to be used as a helper one and that'll be cleared before exiting macro. In the above code I assumed it's one column to the right of "AB"
The following approach worked for me! I'm using a button to trigger macro.
Every time it takes the last row and append it to new sheet like a history. Actually you can make a loop for every value inside your sheet.
Sub copyProcess()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim source_last_row As Long 'last master sheet row
source_last_row = 0
source_last_row = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Set copySheet = Worksheets("master")
Set pasteSheet = Worksheets("alpha")
copySheet.Range("A" & source_last_row, "C" & source_last_row).copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub