error im getting this error when using your code
Dim answer As Integer
answer = MsgBox("Äðóêóâàòè?", vbYesNo + vbQuestion, "Äðóê")
If answer = vbYes Then
ActiveSheet.PageSetup.PrintArea = "A1:N27"
ActiveWindow.SelectedSheets.PrintOut
Else
'End
End If
End Sub
need the macro to print areas that are field within range A1:N27 and delete blank can someone solve it?
Due to my fault there where three problems that FaneDuru has found with my workbook that his code didn't worked with my workbook
The rows to be hide/deleted are not empty. They contains formulas...
The result of formula on column D:D is "".
The worksheet in discussion is protected, but without a password
Try the next code, please. It will hide the rows being empty on the range B:L, print and then un-hide them. The updated code is done according to your last specifications (there are formulas in the 'empty' rows, in column D:D the formula result is "" and the worksheet is protected, but without a password):
Sub testRemoveRowsPrintAreaSet()
Dim sh As Worksheet, lastRow As Long, rngDel As Range, i As Long
Set sh = ActiveSheet
lastRow = sh.Range("C" & Rows.Count).End(xlUp).Row
For i = 9 To lastRow
Debug.Print WorksheetFunction.CountBlank(sh.Range("B" & i & ":L" & i))
If WorksheetFunction.CountBlank(sh.Range("B" & i & ":L" & i)) = 10 Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("M" & i)
Else
Set rngDel = Union(rngDel, sh.Range("M" & i))
End If
End If
Next i
If Not rngDel Is Nothing Then
sh.Unprotect
rngDel.EntireRow.Hidden = True
End If
sh.PageSetup.PrintArea = "A1:N" & lastRow
ActiveWindow.SelectedSheets.PrintOut
rngDel.EntireRow.Hidden = False
sh.Protect
End Sub
Please, confirm that it work as you need.
Related
When running code that deletes an EntireRow, going to next cell will not delete the next cell based on the same parameters because that cell gets moved down into the current slot.
IE:
for each cell in r
if cell.value = "A" then cell.entirerow.delete
next cell
The above code will delete A1 if A1="A" but if A2 also = "A" it will not be deleted because when it goes to next cell A2 it was moved to A1. When it's now looking at A2, that is the cell that was A3, so at best it looks at every other cell.
To get around this i do stuff like this:
DoItAgain:
For Each cell In r
If cell.Value = "A" Then
cell.EntireRow.Delete
GoTo DoItAgain
End If
next cell
This works well but when running this code on 100k lines, it takes way too long. I'm thinking that's because my DoItAgain method brings it all the way back to the first cell and that's a lot of cells to loop through if there's 100k or more cells to look at.
This is the entire code I'm using right now. It was working very well until I started receiving a lot more data and then it's taking too long for it to be useful:
Private Sub Ford_Inventory_Variance_File_CleanUp()
Call ScreenOff
If IsEmpty(Range("A2")) Then Range("A2").EntireRow.Delete
If IsEmpty(Range("A1")) Then Range("A1").EntireRow.Delete
LastRow = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
DoItAgain2:
Set r = ActiveWorkbook.ActiveSheet.Range("A20:A" & LastRow)
For Each cell In r
If cell.Value = "**** End Of Report ****" Then GoTo ItsTrimmed
cell.Value = Trim(cell.Value)
If IsEmpty(cell.Value) Then
cell.EntireRow.Delete
GoTo DoItAgain2
End If
Next cell
ItsTrimmed:
DoItAgain:
For Each cell In r
If cell.Value = "**** End Of Report ****" Then Exit Sub
If InStr(1, (cell.Value), "/") = 0 And InStr(1, (cell.Value), "Total of Inventory") = 0 Then
cell.EntireRow.Delete
GoTo DoItAgain
End If
If Not IsNumeric(Left(cell.Value, 1)) And InStr(1, (cell.Value), "Total of Inventory") = 0 Then
cell.EntireRow.Delete
GoTo DoItAgain
End If
Next cell
Call ScreenOn
End Sub
Screenupdating is off, but this code takes forever. instead of Next cell can I use Previous cell? Is previous cell a thing? Maybe I could use previous cell instead of GoTo DoItAgain?
Any input on how to speed this up will be greatly appreciated. I write codes like this a lot using my GoTo DoItAgain method, i probably have 100 macro's like this, but I might need a better way. My boss is entrusting me with more work but I need to speed this process up.
Thank you in advance.
Try the next code, please. It is untested, but it should work. It, basically, works on the next mechanism: It iterates between all cells of the defined range and check each of them against the set conditions. If a condition is True, it marks the cell like necessary to be deleted (making the boolean variable True). After that, in case of boolToDelete = True, the respective cell it is added to the rngDel (range to be deleted). Finally, usingrngDel, all the rows are deleted at once (very fast):
Private Sub Ford_Inventory_Variance_File_CleanUp()
Dim sh As Worksheet, lastRow As Long, i As Long, rngDel As Range, boolToDelete As Boolean
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
For i = 20 To lastRow
If sh.Range("A" & i).Value = "" Then
boolToDelete = True
ElseIf InStr(sh.Range("A" & i).Value, "/") = 0 And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 Then
boolToDelete = True
ElseIf Not IsNumeric(left(sh.Range("A" & i).Value, 1)) And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 Then
boolToDelete = True
End If
If boolToDelete Then
If rngDel Is Nothing Then 'for first time (when rngDel is nothing)
Set rngDel = sh.Range("A" & i)
Else 'next times a union of existing rngDel and the processed cell is created
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End If
boolToDelete = False 'reinitialize the boolean variable
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp 'rng deletion at once
End Sub
FaneDuru gets 100% credit for answering my question.
I'm posting the full modified code I'm using however:
Private Sub Ford_Inventory_Variance_File_CleanUp()
Dim sh As Worksheet, lastRow As Long, i As Long, rngDel As Range, boolToDelete As Boolean
If IsEmpty(Range("A2")) Then Range("A2").EntireRow.Delete
If IsEmpty(Range("A1")) Then Range("A1").EntireRow.Delete
lastRow = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set r = ActiveWorkbook.ActiveSheet.Range("A1:N" & lastRow)
For Each cell In r
cell.Value = Trim(cell.Value)
Next cell
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
For i = 20 To lastRow
If sh.Range("A" & i).Value = "" Then
boolToDelete = True
ElseIf InStr(sh.Range("A" & i).Value, "/") = 0 And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 And sh.Range("A" & i).Value <> "**** End Of Report ****" Then
boolToDelete = True
ElseIf Not IsNumeric(Left(sh.Range("A" & i).Value, 1)) And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 And sh.Range("A" & i).Value <> "**** End Of Report ****" Then
boolToDelete = True
End If
If boolToDelete Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End If
boolToDelete = False
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
Everything Dane wrote is fast. The longest part of my code is now the trim function I wrote where it trims all the cells in ("A1:N" & LastRow).
Dim lastrow&, lastCol&, myarray As Range
lastrow = Range("A1").End(xlDown).Row
lastCol = Range("XX1").End(xlToLeft).Column
Set myarray = Range("A1").Resize(lastrow, lastCol)
Range("A1", myarray).Select
So i added the above code to recognise the last column and last row and copy the array
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
Application.WindowState = xlNormal
Windows("Ex-Pakistan Calculator Final.xlsm").Activate
Sheets("MRG").Select
'has to find the last row by itself
Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select
ActiveSheet.Paste
Getting an error on the last line "activesheet.paste" saying copy and pasting area isn't the same size, try selecting one cell. enter image description here
Thing is, "Range("A" & Rows.Count).End(xlUp).Offset(2, 0).Select" does only select one cell, so I don't see the issue.
Following is an ideal way to copy and paste using range selection. You can change this code as per your requirement.
Sub CopyPaste()
Dim selectRange As range
Dim lastrow As Integer
Application.CutCopyMode = False
Sheets("Sheet1").Activate
lastrow = range("A1").End(xlDown).Row
Set selectRange = range("A1:A" & lastrow)
selectRange.Copy
Sheets("Sheet2").range("B1:B" & lastrow).PasteSpecial xlPasteAll
End Sub
Congrats on starting to use VBA. There's several things in your code that could use improvement. You want to avoid using select (a common beginner task). You also don't even need to move around your sheet, or even use copy/paste.
However, see below where I've broken up your code with some statements to stop and check where you're at. I think this will accomplish what you want, but also help you gain a better grasp of what you're doing (it's always a battle getting started!)
Keep battling.
Sub adfa()
Const turnOnStops As Boolean = True 'change to true or false to review code
Dim WS_Pull As Worksheet:
Set WS_Pull = ActiveSheet 'better to define this with actual sheet name
Dim lastrow As Long:
lastrow = WS_Pull.Cells(Rows.Count, 1).End(xlUp).Row 'this assumes column a has the bottom row and no rows hidden
If turnOnStops Then
Debug.Print "Lastrow is " & lastrow
Stop
End If
Dim lastcol As Long:
lastcol = WS_Pull.Cells(1, Columns.Count).End(xlToLeft).Column 'same assumptions but with columns on row 1 instead of columna a
If turnOnStops Then
Debug.Print "lastcol is " & lastcol
Stop
End If
Dim myarray As Range:
Set myarray = WS_Pull.Range("A1").Resize(lastrow, lastcol) ' I'm not sure what you're trying to do here.
If turnOnStops Then
Dim theAnswer As Long
theAnswer = MsgBox("The address of myArray is " & myarray.Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
Dim WS_paste As Worksheet: Set WS_paste = Sheets("MRG") 'it would be better to use the SHEET (shown in the VBA project)
WS_Pull.Range("A1", myarray).Copy '<--- what are trying to copy.
If turnOnStops Then
theAnswer = MsgBox("The area copied was " & WS_Pull.Range("A1", myarray).Address & ". Stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
If turnOnStops Then
theAnswer = MsgBox("The area you are going to paste to is " & _
WS_paste.Cells(1, Rows.Count).End(xlUp).Offset(2, 0).Address & " stop code?", vbYesNo)
If theAnswer = vbYes Then Stop
End If
End Sub
I am trying to create an save button that will copy/paste the previous answer to a new row. But not just one, I want it to save up as many as you can, listing them below each other.
It is just for a school project, to make a master cheat sheet.
Private Sub Save1_Click()
Dim rA5 As Range
Set rA5 = ThisWorkbook.Sheets(1).Range("A5:E5")
Dim rA7 As Range
Set rA7 = ThisWorkbook.Sheets(1).Range("A7:E7")
If (Range("rA7").Value <> "") Then
If (Range("rA7").Offset(1).Value <> "") Then
Set rA7 = rA7.End(xlDown)
End If
Set rA7 = rA7.Offset(1)
End If
rA7.Value = rA5.Value
End Sub
It only pastes the A5:E5 to A7:E7.
It doesn't go down after that to A8:E8, A9:E9 (and so on)
Preferred outcome image
As per your comment on your own question, it looks like you want the newly calculated value on the top line, and the rest pushed down a line. If that is right, then #Error1004 answer won't work as it sticks your values on the end. The following is his code with an added reverse loop which will stick your new value on the top line and push it down:
Sub test()
Dim LastRow As Long
Dim i As Integer
With ThisWorkbook.Worksheets("Sheet1")
'Check if there is a value in A5
If .Range("A5").Value <> "" Then
'Copy range("A5:E5")
.Range("A5:E5").Copy
'If range A7 is empty
If .Range("A7").Value = "" Then
.Range("A7:E7").PasteSpecial Paste:=xlPasteValues
Else
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
i = LastRow
Do While i > 7
.Range("A" & (i + 1) & ":E" & (i + 1)).Value = .Range("A" & i & ":E" & i).Value
i = i - 1
Loop
.Range("A7:E7").Value = .Range("A5:E5").Value
End If
Else
MsgBox "There is no available data to be save."
End If
End With
End Sub
Credit to #Error1004 as I cannibalised his answer for this code.
You could try:
Option Explicit
Sub test()
Dim LastRow As Long
With ThisWorkbook.Worksheets("Sheet1")
'Check if there is a value in A5
If .Range("A5").Value <> "" Then
'Copy range("A5:E5")
.Range("A5:E5").Copy
'If range A7 is empty
If .Range("A7").Value = "" Then
.Range("A7:E7").PasteSpecial Paste:=xlPasteValues
Else
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(LastRow + 1, "A"), .Cells(LastRow + 1, "E")).PasteSpecial Paste:=xlPasteValues
End If
Else
MsgBox "There is no available data to be save."
End If
End With
End Sub
*EDIT
Here is what ended up kind of working. The solutions below do not run the AddProj when new row is inserted.
Sub Worksheet_Calculate()
Dim X As Range
Set X = LastCell 'The X is superflous, you could just use the LastCell variable
If Sheet5.Range("A" & Rows.Count).Value < X.Value Then
X.Value = Me.Range("A" & Rows.Count).Value
AddProj
End If
End Sub
Module 1 contains the following:
Function LastCell() As Range
With Sheet5
Set LastCell = .Cells(Rows.Count, 1).End(xlUp)
End With
End Function
Sub AddProj()
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
End Sub
I am trying to read the data in the last cell of a column.
The value of "X" should be the value of this last cell.
I then want "X" to be compared to the number of rows and if the number of rows is less than "X", perform my macro "AddProj".
Once "X" and Column A are the same value, nothing else is to be done.
For some reason, it is not working.
This code is on the worksheet where I want the comparison to be made.
Please see my code below:
Private Sub Worksheet_Calculate()
X = LastCell
If Sheet5.Range("A" & Rows.Count).Value < Sheet5.Range("X").Value Then
Sheet5.Range("X").Value = Me.Range("A" & Rows.Count).Value
AddProj
End If
End Sub
Sub LastCell()
Range("A1").End(xlDown).Select
End Sub
The "AddProj" is a module that is referenced in the code above (thank you #jsheeran #SJR ACyril for help):
Sub AddProj()
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
End Sub
Thanks in advance.
Try this:
Sub Worksheet_Calculate()
Dim lRow As Long
lRow = Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row
If Sheet5.Cells(lRow, 1) > lRow Then
Sheet5.Cells(lRow, 1) = lRow
AddProj
End If
End Sub
X is a variable but you refer to it as "X". Also avoid using .Select as it is not necessary and even in this case just does nothing, because first of all a Sub cannot return a value and second .Select has also no return value. The best way to calculate the last row is this: Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row
Here is just a slight variation on UPGs great answer.
Dim lRow As Long
lRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
If lRow >= Sheet1.Cells(lRow, 1) Then
Exit Sub
Else: AddProj
End If
My sheet look like :
I have a function to get index of the LAST empty cell in column A:
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
This function works to write on second array (Type2).
But now, i would like a function to get index of the FIRST empty cell in column A. So i went to this website: Select first empty cell and i tried to adapt code but it's doesn't work:
If Array= "Type1" Then
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(1).Cells
If IsEmpty(cell) = True Then NextRow = cell: Exit For 'ERROR 1004
Next cell
End If
If Array= "Type2" Then 'It s works
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
End If
ActiveSheet.Range("A" & NextRow) = "TEST"
Could you help me to adapt my code to have NextRow = IndexOf FIRST empty cell in A ?
You could just use the same method you did to get the last one.
NextRow = Range("A1").End(xlDown).Row + 1
I do this and it' works:
If Array= "Type1" Then
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(1).Cells
If IsEmpty(cell) = True Then
NextRow = cell.Row
Exit For
MsgBox NextRow
End If
Next cell
End If
If Array= "Type2" Then 'It s works
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
End If
ActiveSheet.Range("A" & NextRow) = "TEST"
You should look bottom up for this.
And Find is better than xlUp.
Sub FindBlank()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = ActiveSheet
Set rng1 = ws.Columns(1).Find("*", ws.[a1], xlFormulas, , xlByColumns, xlPrevious)
If Not rng1 Is Nothing Then
MsgBox "Last used cell is " & rng1.Address(0, 0)
Else
MsgBox ws.Name & " row1 is completely empty", vbCritical
End If
End Sub
I took a similar approach to some of the answers, but with the goal of repeatedly looking down the column until I could guarantee that there was no more populated cells below.
I turned this into a small function that I put in a standard module:-
Public Function getFirstBlankRowNumberOnSheet(sht As Worksheet, Optional startingRef As String = "A1") As Long 'may get more than 32767 rows in a spreadsheet (but probably not!)
Dim celTop As Range
Dim celBottom As Range
On Error Resume Next
Set celTop = sht.Range(startingRef)
Do
Set celBottom = celTop.End(xlDown)
Set celTop = celBottom.Offset(1) 'This will throw an error when the bottom cell is on the last available row (1048576)
Loop Until IsEmpty(celBottom.value)
getFirstBlankRowNumberOnSheet = celTop.Row
End Function
This will throw an error if there happens to be content in the row #1048576! The particulars of this are dependent on the Excel version I suppose in terms of maximum row cont allowed.