I have the code below to hide all blank cells on my sheet. How do I set the hide range to 100 so after cell 100 if the remaining ones are blank it doesn't hide them. Only cells within the 1-100 limit get hidden if blank.
Sub HideRow()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Projects Dashboard")
Dim LRowC, LRowD, LRowF, LRowH, LRow As Long
LRowC = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
LRowD = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
LRowF = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
LRowH = ws.Range("H" & ws.Rows.Count).End(xlUp).Row
LRow = Application.WorksheetFunction.Max(LRowC, LRowD, LRowF, LRowH)
Dim I As Long
Application.ScreenUpdating = False
ws.Rows.Hidden = False
For I = LRow To 7 Step -1
If ws.Range("C" & I).Text = "" And ws.Range("D" & I).Text = "" And ws.Range("F" & I).Text = "" And ws.Range("I" & I).Text = "" Then
ws.Rows(I).EntireRow.Hidden = True
End If
Next I
Application.ScreenUpdating = True
End Sub
If I understand your question and code, it seems that you would want limit your LRow value to be a max of 100.
Should be as simple as adding one line of code:
...
LRow = Application.WorksheetFunction.Max(LRowC, LRowD, LRowF, LRowH)
If LRow > 100 Then LRow = 100
Dim I As Long
...
Related
I have columns from A - S, where I need to delete the headers and blank cells, my criteria for lookup in deleting headers are "Transaction" & "Source" but it seems it's skipping rows. I have a total of 79,000 rows but code only goes till 39,000. I've tried everything I can find over. still nothing happens.
I'm also starting the formatting and deleting on row 209 up to lastrow.
Option Explicit
Sub Project_M()
Dim lastrow As Long
Dim cc As Long
Dim dd As Long
lastrow = WorksheetFunction.CountA(Columns(1))
Application.ScreenUpdating = False
Call ClearFormats
lastrow = WorksheetFunction.CountA(Columns(1))
Columns(1).Insert shift:=xlToRight
Range("A209:A" & lastrow).Formula = "=ROW()" 'inserting dummy rows
Range("A209:A" & lastrow).Value = Range("A210:A" & lastrow).Value
Range("U209:U" & lastrow).Formula = "=IF(AND(ISERROR(SEARCH(""Transaction"",B209)),ISERROR(SEARCH(""Source"", B209))),1,0)"
Range("U209:U" & lastrow).Value = Range("U209:U" & lastrow).Value
''''' delete headers : only working till row 39,0000
Range("A209:U" & lastrow).Sort Key1:=Range("U209"), Order1:=xlAscending
cc = WorksheetFunction.CountIf(Columns(21), "0")
If cc <> 0 Then
Range("A209:U" & cc).Select
Range("A209:U" & cc).EntireRow.Delete
lastrow = lastrow - cc
End If
Range("A209:U" & lastrow).Sort Key1:=Range("A209"), Order1:=xlAscending
Range("U:U").ClearContents
Range("A:A").Delete
ActiveSheet.UsedRange.Columns.AutoFit
End Sub
Sub deleteBlank() 'not working
Dim lastrow As Integer
lastrow = Range("A" & rows.Count).End(xlUp).Row
Range("B2:B" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub ClearFormats() ' working
Dim rng As Range
Dim lastrow As Long
Dim ws As Worksheet
lastrow = Range("A" & rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
On Error Resume Next
Set rng = Range("A209:S" & lastrow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.ClearFormats
End If
On Error Resume Next 'not working in deleting blank cells
ws.Columns("A209:S" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub
Sub DeleteExtra() ' not working
Dim Last As Long
Dim i As Long
Last = Cells(rows.Count, "A").End(xlUp).Row
For i = Last To 1 Step 1
If (Cells(i, "A209").Value) = "Transaction" And (Cells(i, "A209").Value) = "Source" And (Cells(i, "A209").Value) = "" And (Cells(i, "A209").Value) = " " Then
Cells(i, "A").EntireRow.Delete
End If
Next i
End Sub
Sub deleteBlankcells() '''not working
Dim lastrow As Long
Dim cc As Long
lastrow = WorksheetFunction.CountA(Columns(1))
Range("A209:A" & lastrow).Formula = "=ROW()" 'inserting dummy rows
Range("A209:A" & lastrow).Value = Range("A210:A" & lastrow).Value
Range("U209:U" & lastrow).Formula = "=IF(AND(ISBLANK(A209),ISBLANK(A209)),0,1)"
Range("U209:U" & lastrow).Value = Range("U209:U" & lastrow).Value
Range("A209:U" & lastrow).Sort Key1:=Range("U209"), Order1:=xlAscending
cc = WorksheetFunction.CountIf(Columns(21), "0")
If cc <> 0 Then
Range("A209:U" & cc).Select
Range("A209:U" & cc).EntireRow.Delete
lastrow = lastrow - cc
End If
Range("A209:U" & lastrow).Sort Key1:=Range("A209"), Order1:=xlAscending
Range("U:U").ClearContents
Range("A:A").Delete
End Sub
I've tried different attempts but not working. codes are commented.
Thanks!
With the help and ideas of users, I've come to this simple code and got it working.
Credits to all of them! Cheers!
Option Explicit
Sub Project_M()
Dim Last As Long
Dim i As Long
Application.ScreenUpdating = False
Last = cells(rows.Count, "A").End(xlUp).Row
Range("A209:S" & Last).UnMerge
Range("A209:S" & Last).WrapText = False
For i = Last To 209 Step -1
If (cells(i, "A").Value) = "Source" Or (cells(i, "A").Value) = 0 Or (cells(i, "A").Value) = "End of Report" Or (cells(i, "A").Value) = "Transaction" Then
cells(i, "A").EntireRow.Delete
End If
Next i
ActiveSheet.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Starting from the last row of the column for i = Last up to the row I want to start my formatting and deleting To 209 and Step -1 to move up.
I am having a problem with my loop(i go throu columns in every worksheet and copy them common column ) in VBA. And I wan't to ignore empty cells... any ideas? Bellow is my code
Application.ScreenUpdating = False
lastRowMaster = 1
For Each Ws In Sheets(Array("1L", "5L"))
lastRow = Ws.Range("A" & Rows.Count).End(xlUp).row
Ws.Range("A1:A" & lastRow).Copy Destination:=Worksheets("Podatki plana").Range("A" & lastRowMaster)
lastRowMaster = Worksheets("Podatki plana").Range("A" & Rows.Count).End(xlUp).row + 1
Next
Application.ScreenUpdating = True
MsgBox "Done!"
I altered this line of code:
Ws.Range("A1:A" & lastRow).Copy Destination:=Worksheets("Podatki plana").Range("A" & lastRowMaster)
To this:
Ws.Range("A1:A" & lastRow).SpecialCells(xlCellTypeConstants).Copy Destination:=Worksheets("Podatki plana").Range("A" & lastRowMaster)
Using the .SpecialCells(xlCellTypeConstants) qualifier selects only cells that have a value in them. You could change xlCellTypeConstants to xlCellTypeFormulas or any of the options listed on this MSDN article.
The benefit with this is that you don't have to loop through each cell, which is a perfectly good solution but comes with a performance penalty.
Tested in Excel 2013.
Maybe just set each of the destination cells to the origin cell when the cell is not empty, like so
Application.ScreenUpdating = False
lastRowMaster = 1
lastRow = Ws.Range("A" & Rows.Count).End(xlUp).row
nextRow = 1
For Each Ws In Sheets(Array("1L", "5L"))
for i = 1 to lastRow
if Not IsEmpty(Ws.Cells(i, 1)) then
Worksheets("Podatkiplana").cells(nextRow, 1) = Ws.cells(i,1)
nextRow = nextRow + 1
end if
next i
Next
Application.ScreenUpdating = True
MsgBox "Done!"
Application.ScreenUpdating = False
lastRowMaster = 1
For Each Ws In Sheets(Array("1L", "5L"))
lastRow = Ws.Range("A" & Rows.Count).End(xlUp).row
For i = 1 to lastrow
lastRowMaster = Worksheets("Podatki plana").Range("A" & rows.Count).End(xlUp).row + 1
If ws.cells(i, 1)<> "" Then Worksheets("Podatki plana").Cells(lastRowMaster, 1) = ws.cells(i,1)
next i
Next
Application.ScreenUpdating = True
MsgBox "Done!"
I am trying to write a change log for excel VBA. I want it to iterate through so that the each additional response is populated in the workbook as the additional rows. Please let me know if you have any insight into what is wrong with my code
Dim streply As String
Dim Today As Date
Dim myrange As Range
Dim inglastrow As Long
CurrentDate = Date
With Sheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
nextrow = lastrow + 1
MsgBox lastrow
MsgBox nextrow
End With
MsgBox lastrow
streply = InputBox(Prompt:="Please type description of changes", Title:="Change Log", Default:="Brief Desc.")
If streply <> " " Then
Range("A" & nextrow).Value = Application.UserName
Range("B" & nextrow).Value = streply
Range("C" & nextrow).Value = ActiveWorkbook.Name
Range("D" & nextrow).Value = Date
End If
Set lastrow = Nothing
Set nextrow = Nothing
End Sub
EDIT: silly mistake on my part, fixed now
Instead of:
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
Try:
lastrow = .UsedRange.Rows.Count
Hi all I need to selectively copy entire rows from sheet1 to other sheet. As of now I am using checkboxes to select the rows and then copy the selected rows to sheet of user's choice. But I am facing a bizarre error. For sometime the code runs fine, copying exact data to sheets but after some time it copies erroneous values from nowhere. Can you please help me with this? Pasting the code I am using.
Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double
Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For cell = 2 To LRow
If Cells(cell, "A").Value <> "" Then
MyLeft = Cells(cell, "E").Left
MyTop = Cells(cell, "E").Top
MyHeight = Cells(cell, "E").Height
MyWidth = Cells(cell, "E").Width
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.Display3DShading = False
End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
End Sub
Sub CopyRows()
Dim Val As String
Val = InputBox(Prompt:="Sheet name please.", _
Title:="ENTER SHEET NAME", Default:="Sheet Name here")
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":AF" & LRow) = _
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub
Normal Copy Output:
Erroneous Copy Output for same values:
Doing a quick comparison of the normal and the erroneous outputs, it looks like some of your cells/columns are not formatted correctly in your destination sheet (where you are "pasting" the values).
For example, your Base Change column in the Normal copy (the value 582.16) is formatted as a General or Number. The same column in the destination sheet is formatted as a date (582.16 converted to a date value in Excel will be 8/4/1901, or 8/4/01, as shown in your screen.
Just make sure the columns are formatted to display the data type you expect. On your destination sheet, select the column, right-click "Format Cells", and then select the appropriate data type.
---EDIT---
To automate the formatting, you would have to copy and paste the values, inclusive of the formats. Your code would change from this:
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":AF" & LRow) = _
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With
TO
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Copy
.Range("A" & LRow).PasteSpecial (xlPasteValuesAndNumberFormats)
End With
I have added the checkbox with LinkedCell property. This helps to identify the rows when checkbox is checked.
Also i have added a function check_worksheet_exists which will check if the workbook exist.
Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double
Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).row
For cell = 2 To LRow
If Cells(cell, "A").Value <> "" Then
MyLeft = Cells(cell, "E").Left
MyTop = Cells(cell, "E").Top
MyHeight = Cells(cell, "E").Height
MyWidth = Cells(cell, "E").Width
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.Display3DShading = False
.LinkedCell = Cells(cell, "AZ").Address
End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
End Sub
Sub CopyRows()
Dim Val As String
Dim row As Long
Val = InputBox(Prompt:="Sheet name please.", Title:="ENTER SHEET NAME", Default:="Sheet Name here")
If check_worksheet_exists(ThisWorkbook, Val, False) = False Then
Exit Sub
End If
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
row = Range(chkbx.LinkedCell).row
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).row + 1
.Range("A" & LRow & ":AF" & LRow) = ActiveSheet.Range("A" & row & ":AF" & row).Value
End With
End If
Next
End Sub
Function check_worksheet_exists(tBook As Workbook, ByVal check_sheet As String, Optional no_warning As Boolean = False) As Boolean
On Error Resume Next
Dim wkSht As Worksheet
Set wkSht = tBook.Sheets(check_sheet)
If Not wkSht Is Nothing Then
check_worksheet_exists = True
ElseIf wkSht Is Nothing And no_warning = False Then
MsgBox "'" & check_sheet & "' sheet does not exist", vbCritical, "Error"
End If
On Error GoTo 0
End Function
i cannot immediately see the errors you refer to, unless you are referring to the sequences of hash-signs ###? These just indicate that the columns aren't wide enough.
Worksheets(Val).Range("A1").CurrentRegion.EntireColumn.AutoFit
BTW I don't think Val is a sensible variable name ;)
I have the following code. I was wondering if there is an easy way to rewrite it so that it takes less time to run? Currently, I have about 13,000 rows to loop through and it takes approximate 3-5 minutes to run. Thanks!
Sheets("wkly").Activate
Dim i As Long
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Range("S" & i) > 0.005 Then
Range("Z" & i, "AA" & i).Copy
Range("AC" & i, "AD" & i).PasteSpecial xlPasteValues
End If
Application.ScreenUpdating = False
Next i
I believe this will help make it a lot faster. No looping and no copy and paste needed.
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim wks As Worksheet, Lastrow As Long
Set wks = Sheets("wkly")
With wks
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("S1:S" & Lastrow).AutoFilter 1, ">.005"
'Assumes you will always have values greater than .005, if not you need to error trap
Dim rngFilter As Range
Set rngFilter = .Range("S2:S" & Lastrow).SpecialCells(xlCellTypeVisible) 'assumes row 1 is header row
rngFilter.Offset(, 10).Value = rngFilter.Offset(, 7).Value
rngFilter.Offset(, 11).Value = rngFilter.Offset(, 8).Value
End With
Application.ScreenUpdating = True
UPDATE
I know you accepted the answer already, but in case you want to know how to do this by using an array to loop through, here it is below:
Dim wks As Worksheet, varStore As Variant, Lastrow As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set wks = Sheets("wkly")
With wks
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
varStore = .Range("S2:S" & Lastrow)
For i = LBound(varStore, 1) To UBound(varStore, 1)
If varStore(i, 1) > 0.005 Then .Range("AC" & i + 2 & ":AD" & i + 2).Value = .Range("Z" & i + 2 & ":AA" & i + 2).Value
Next
End With
Application.ScreenUpdating = False
If you do operations on a large number of cells, copying them into an array and writing them back after the processing is usually the fastest. The following code runs in 0.04s on my machine (based on Scott's answer, but using arrays also for the writing):
Dim wks As Worksheet
Dim varCompare As Variant, varSource As Variant, varTarget As Variant
Dim Lastrow As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set wks = Sheets("wkly")
With wks
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
varCompare = .Range("S2:S" & Lastrow)
varSource = .Range("Z2:AD" & Lastrow)
varTarget = .Range("AC2:AD" & Lastrow)
For i = LBound(varCompare, 1) To UBound(varCompare, 1)
If varCompare(i, 1) > 0.005 Then
varTarget(i, 1) = varSource(i, 1)
varTarget(i, 2) = varSource(i, 2)
End If
Next
.Range("AC2:AD" & Lastrow).Value = varTarget
End With
Application.ScreenUpdating = False
Given all the good tips, and include the following too. Please give a try and see how much performance boost you could achieve.
Application.Calculation = xlCalculationManual
lastrow = Range("S" & Rows.Count).End(xlUp).Rows
For i = 1 To lastrow
If Range("S1").Offset(i) > 0.005 Then
Range("AC").Offset(i).Resize(1, 2).Value = Range("Z").Offset(i).Resize(1, 2).Value
End If
Next i