Don't know what I'm missing, but the examples I see posted do not appear to work.
I import data from a web query. I set the query to clear unused cells when it re-queries.
I used this imported data to generate a report of variable length.
However if the user (as they need to do in my case) insert rows then the ActiveSheet.UsedRange is expanded. This means I cannot any longer just do a "Ctrl-End" to find the last row in the data set when a new query is performed.
I can easily clear any data with ActiveSheet.UsedRange.Clear. However if the previous query generated a 2 or 3 page report any subsequent query will also be that long even when there is less data because the "UsedRange" still points to that last row way down there.
The examples shown like
ActiveSheet.UsedRange
ActiveSheet.UsedRange.Clear
a = ActiveSheet.UsedRange.Rows.Count
do not reset the range.
MS defines UsedRange as a readOnly property.
It appears what needs to happen is a "File Save" in order to complete the action.
ActiveWorkbook.Save
One post noted that in older versions of Excel you also had to close the workbook and reopen it to complete the action.
I would like to know
1. What is the version cutoff where this behavior changed?
2. Is there some other method using a VBA macro which will reset the range?
I only needed to use Worksheets("Sheet1").UsedRange.Calculate
after deleting rows to reset the range.
Best code that worked for me:
Sub DeleteUnused()
Dim myLastRow As Long
Dim myLastCol As Long
Dim dummyRng As Range
Dim AnyMerged As Variant
'http://www.contextures.on.ca/xlfaqApp.html#Unused
'Helps to reset the usedrange by deleting rows and columns AFTER your true used range
'Check for merged cells
AnyMerged = ActiveSheet.UsedRange.MergeCells
If AnyMerged = True Or IsNull(AnyMerged) Then
MsgBox "There are merged cells on this sheet." & vbCrLf & _
"The macro will not work with merged cells.", vbOKOnly + vbCritical, "Macro will be Stopped"
Exit Sub
End If
With ActiveSheet
myLastRow = 0
myLastCol = 0
Set dummyRng = .UsedRange
On Error Resume Next
myLastRow = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, lookat:=xlWhole, _
searchdirection:=xlPrevious, _
searchorder:=xlByRows).Row
myLastCol = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, lookat:=xlWhole, _
searchdirection:=xlPrevious, _
searchorder:=xlByColumns).Column
On Error GoTo 0
If myLastRow * myLastCol = 0 Then
.Columns.Delete
Else
.Range(.Cells(myLastRow + 1, 1), _
.Cells(.Rows.Count, 1)).EntireRow.Delete
.Range(.Cells(1, myLastCol + 1), _
.Cells(1, .Columns.Count)).EntireColumn.Delete
End If
End With
End Sub
I've used Jeeped solution and worked for me when i add .Activate, so:
With Worksheets("Sheet1")
Debug.Print .UsedRange.Address(0, 0)
.UsedRange.Clear
.UsedRange
.Activate
Debug.Print .UsedRange.Address(0, 0)
End With
I'm using Excel2013
select cell 1,1 in any sheets you want to reset the UsedRange property
Calculate all worksheets in all open workbooks,
regardless of whether they changed since last calculation
(To Calculate Fully Ctrl+Alt+F9)
Save the workbook
Works for me on all versions of excel
This is what ended up working for me. I feel there has to be a better way but no others worked for me.
Sub ClearRangeData()
Dim S1 As Worksheet
Set S1 = Sheets("Your Sheet Name") 'Define what sheets we are using
'------- Remove all the old data -----
S1.Activate
With ActiveSheet
S1_rows = S1.UsedRange.Rows.Count
For I = S1_rows To 1 Step -1
Cells(I, 1).EntireRow.Delete
Next
End With
End Sub
If you call the Worksheet.UsedRange property by itself, it will reset.
With Worksheets("Sheet1")
Debug.Print .UsedRange.Address(0, 0)
.UsedRange.Clear
.UsedRange '<~~ called by itself will reset it
Debug.Print .UsedRange.Address(0, 0)
End With
This extra step is unnecessary in xl2010 and above with all appropriate service packs installed.
Here is how I inserted your code.
Sheets("Edit Data").Select
' Range("A6").Select
' Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
' Selection.Delete Shift:=xlUp
' ActiveWorkbook.Save
With Worksheets("Edit Data")
Debug.Print .UsedRange.Address(0, 0)
.UsedRange.Clear
.UsedRange '<~~ called by itself will reset it
Debug.Print .UsedRange.Address(0, 0)
End With
Here is the full used range with data
Here is the used range after your code executed
The end of range should be i7 instead it is still i26
However the code which I commented out does reset range to i7
From what you are saying just to confirm. My commented out code will only work for Excel 2010 and newer. We have some 2007 versions hanging around. For those the workbook will actually have to be closed and reopened for the range to reset?
Note- the code examples were executed on version 2016
This may or may not suit your data needs, but if your data is all in one contiguous block, you can use CurrentRegion instead of UsedRange, like this:
With Cells(1, 1).CurrentRegion
MsgBox "I have " & .Rows.Count & " rows and " & .Columns.Count & " columns of data."
End With
Of course, if the region you care about does not start at cell A1, or if your sheet contains multiple contiguous regions that you care about, this option will not work. Depending on how predictable your data is, you can usually find at least one cell in each block of data, and once you have that, CurrentRegion will give you the range of the entire block.
Thanks to Claus for having the correct answer, but it is incomplete, and he completed it with a comment on the main post. I'll answer here to combine the useful bits into a single working solution.
Note: I have not tried variations to see which steps are necessary, but these steps work to clear unnecessary used range.
Sub ResetUsedRange()
dim rngToDelete as range
set rngToDelete = 'Whatever you want
rngToDelete.EntireRow.Clear
rngToDelete.EntireRow.Select
Selection.Delete Shift:=xlUp
ActiveWorkbook.Save 'This step has been stated to be necessary for the range to reset.
End Sub
This is the solution I used.
Sub CorrectUsedRange()
Dim values
Dim usedRangeAddress As String
Dim r As Range
'Get UsedRange Address prior to deleting Range
usedRangeAddress = ActiveSheet.UsedRange.Address
'Store values of cells to array.
values = ActiveSheet.UsedRange
'Delete all cells in the sheet
ActiveSheet.Cells.Delete
'Restore values to their initial locations
Range(usedRangeAddress) = values
End Sub
My Excel VBA program imports data from access database by a given date range.
Whenever a new set of data is populated, the worksheet UsedRange does not shrink to reflect only rows with data but instead stays the same even when there are blank rows after the last row with data.
This creates difficulty scrolling down the worksheet to view data.
So to reset UsedRange in order to just reflect rows with data, see below code.
I hope it helps someone.
Sub ResetUsedRange(ByVal oSht As Excel.Worksheet)
' ________________________________________________________________
' Resetting UsedRange to reset vertical scroll bar on Worksheet,
' to reflect ONLY rows with data. This can reset UsedRange on any
' Worksheet. Just pass the worksheet object to this sub.
' ================================================================
Dim iRow1 As Long ' This will get the last row with data
Dim iRow2 As Long ' This will get the number of rows in UsedRange
With oSht
' Format cells to remove wrap text option
' Importing from Access makes some cells with wrap text
.UsedRange.Cells.WrapText = False
' Find last row with data on worksheet
iRow1 = .Cells(.Rows.count, 1).End(xlUp).Row
' Get number of rows in UsedRange
iRow2 = .UsedRange.Rows.count
' If UsedRange rows exceeds the last row with data
' then delete the rows which obviously are blank
If iRow2 > iRow1 Then
.Range(.Cells(iRow1 + 1, 1), .Cells(iRow2, 1)).EntireRow.Delete
End If
' following code forces UsedRange to recalculate and resets
' to reflect ONLY rows with data if blank rows in the UsedRange
' were deleted making the vertical scroll bar to reset itself.
.UsedRange.Calculate
End With
End Sub
I just wanted to put my 2 cents in here since I was also having this problem until I realized the problem.
If you have a UsedRange that is A1:H20 and you delete the row by saying ActiveSheet.Range("A2:H2).Delete you'll find that your UsedRange hasn't updated, it will still show A1:H20. However, if you either say ActiveSheet.Rows(2).Delete or ActiveSheet.Range("A2:H2).EntireRow.Delete You'll find that the UsedRange does update. For some reason you have to delete entire rows or columns (depending your condition) to get that UsedRange to update.
Hope this helps someone!
This worked for me:
Worksheets("Sheet1").UsedRange.Clear
Worksheets("Sheet1").UsedRange = ""
It appears that inserting a value into the UsedRange resets it. After this action I can go
MyCurrentRow = Worksheets("Sheet1").Range("A:A").SpecialCells(xlCellTypeLastCell).Row
MyCurrentRow comes now back as 1, and I can just count from there. When I did not assign a value into UsedRange, that LastCell value did not reset. No Save required.
This works for me in Excel 2010:
Worksheets("Sheet1").UsedRange.Clear
Worksheets("Sheet1").UsedRange.Calculate
I double checked to make sure all the latests patches and service packs have been installed and they were.
I'm running
Windows 10 and
Excel 2016 version 16.0.6568.2034
I found that the range would only reset with the
ActiveSheet.UsedRange.Clear
And most importantly
ActiveWorkbook.Save
without the save command the range is not reset
Related
I am working on a macro to go through stock data. When no data is available on a given date, the data shows "-" in those rows. I need to delete those rows.
I have come up with a macro that deletes the first row found. I need to keep it going until all rows with "-" are deleted.
How can I do this with a Do Until loop?
Sub removejank()
'
' removejank Macro
Cells.Find(What:="-", After:=ActiveCell, LookIn:=xlFormulas2, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
If ActiveCell.Value = "-" Then
Rows(ActiveCell.Row).Delete
End If
End Sub
There are many possible ways to loop through and delete rows.
In your example, using Activate significantly slows down runtime when you are looping data. .Activate is almost completely avoidable in just about every circumstance. Obviously, I see that what you've done was with the macro recorder, so it's understandable that it's there.
Anyway, try the following code. This only looks in column A. If you need to look in a different column, then change the "1" in this line:
If .Cells(r, 1).Value = "-" Then
To the column # you want to look in. Also, you will likely need to change the sheet name in this line:
With ThisWorkbook.Worksheets("Sheet3")
to match the sheet name you are wanting the code to run in.
So the way this method of the many methods out there works is that you will loop through every line in column A with For r = 1 .... Each loop iteration you are looking in the cell's value. If it equals -, then the If statement is true and proceeds to add the cell to our special range that we named delRng. You are not actually deleting the row just yet, only tracking them in this range.
Once finished, you will take all the single cells in the delRng, and using the .EntireRow property, delete them all at once. This is generally faster than deleting rows one at a time.
Public Sub RemoveJunk()
Dim delRng As Range, r As Long
With ThisWorkbook.Worksheets("Sheet3")
For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(r, 1).Value = "-" Then
If delRng Is Nothing Then
Set delRng = .Cells(r, 1)
Else
Set delRng = Union(delRng, .Cells(r, 1))
End If
End If
Next r
End With
If Not delRng Is Nothing Then delRng.EntireRow.Delete
End Sub
I am trying to copy filtered data from one sheet to another, but for some reason I get a runtime error 1004 saying "to copy all cells from another worksheet to this worksheet make sure you paste them into the first cell (A1 or R1C1)" I actually don't want the header row copied, so all visible bar that row
What I am wanting is the copied data to be pasted to the first available row in the target sheet. Here is the code I have which filters for certain things, but then falls over on the paste line
Sub BBWin()
'
' BB Win Macro
' This macro will filter BB Win 1 - 8
'
With ActiveSheet.Range("A1").CurrentRegion
With .Resize(, .Columns.Count + 1)
With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
.FormulaR1C1 = "=if(or(rc7={""K.BB_Win_1_2019"",""K.BB_Win_2_2019"",""K.BB_Win_3_2019"",""K.BB_Win_4_2019"",""K.BB_Win_5_2019"",""K.BB_Win_6_2019"",""K.BB_Win_7_2019"",""K.BB_Win_8_2019""}),""X"","""")"
.Value = .Value
End With
.HorizontalAlignment = xlCenter
End With
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub
Any suggestions as to what is missing to have it work correctly?
=========================================
OK, perhaps I should have tried the question another way, posting the original working macro I was supplied, rather than posting my attempt to rewrite it.
This is basically the same thing as what I posted above, with the formula changed to look for different text, though it also has autofilter settings (which I don't need) and hides columns (which I don't need to do). This is working perfectly for me and does exactly what it is supposed to. I basically tried to duplicate it and remove the unwanted elements, but as you saw, found the error originally indicated. Obviously my limited knowledge caused the initial issue.
Sub Low_Risk()
'
' Low Risk Lays Macro
' This macro will filter for Remove VDW Rank 1, Class, Distance <=1650, # of Runners <=9, Exclude Brighton, Yarmouth, Windsor & Wolverhampton
'
With ActiveSheet.Range("A1").CurrentRegion
With .Resize(, .Columns.Count + 1)
With .Cells(2, .Columns.Count).Resize(.Rows.Count - 1)
.FormulaR1C1 = "=if(or(rc8={""Brighton"",""Yarmouth"",""Windsor"",""Wolverhampton""}),""X"","""")"
.Value = .Value
End With
.AutoFilter Field:=4, Criteria1:="<=9"
.AutoFilter Field:=11, Criteria1:="<=1650"
.AutoFilter .Columns.Count, "<>X"
.AutoFilter Field:=29, Criteria1:="<>1"
.HorizontalAlignment = xlCenter
End With
.Columns("C:C").EntireColumn.Hidden = True
.Columns("G:G").EntireColumn.Hidden = True
.Columns("I:I").EntireColumn.Hidden = True
.Columns("L:L").EntireColumn.Hidden = True
.Columns("N:W").EntireColumn.Hidden = True
.Columns("Y:AB").EntireColumn.Hidden = True
.Columns("AD:AJ").EntireColumn.Hidden = True
.Columns("AO:AO").EntireColumn.Hidden = True
.Columns("AQ:BQ").EntireColumn.Hidden = True
.Columns("BT:CP").EntireColumn.Hidden = True
.Parent.AutoFilter.Range.Offset(1).Copy
Workbooks("New Results File.xlsm").Sheets("Low Risk Lays").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub
As indicated, this works absolutely perfectly, nested Withs and all. I can change the original formula so it is looking in the correct column and only for the text I want, but I obviously was not able to successfully remove the autofilter elements and the elements which hide columns without bringing up an error. I assume the removal of the .Parent.AutoFilter.Range.Offset(1).Copy line was the culprit, but wasn't sure how to approach the removal of the unwanted elements.
This original macro was supplied to me in one of the forums and I am loath to alter the formula part which does a good job of looking for the many text elements required to be copied. That was why I only looked to alter the autofilter section and hidden column section
I'm not sure if this helps at all, but it may clarify things a little
cheers and thanks so much for your effort
Cells.Select (with no leading period to tie it to the With block) will select all cells on whatever is the active sheet.
Try this (nested With's confuse me a bit, so removed a couple)
Sub BBWin()
Dim arr, ws As Worksheet, lc As Long, lr As Long
arr = Array("K.BB_Win_1_2019", "K.BB_Win_2_2019", "K.BB_Win_3_2019", _
"K.BB_Win_4_2019", "K.BB_Win_5_2019", "K.BB_Win_6_2019", _
"K.BB_Win_7_2019", "K.BB_Win_8_2019")
Set ws = ActiveSheet
'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ws.Range("A1", ws.Cells(lr, lc))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=7, Criteria1:=arr, Operator:=xlFilterValues
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
End With
Workbooks("Predictology-Reports.xlsx").Sheets("BB Reports") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
Cells.Select selects all sheets cells.
Selection.SpecialCells(xlCellTypeVisible) keeps all cells, since nothing is hidden and everything is visible. You said something about "copy filtered data" but your code does not filter anything...
So, there is not place to paste all cells.
In order to make your code working, replace Cells.Select with .Cells.Select (the dot in front makes it referring to the resized UsedRange). Even if any selection is not necessary...
So, (better) use .cells.SpecialCells(xlCellTypeVisible).Copy...
Edited:
Your last code needs to only copy the visible cells of the filtered range. So, your code line
.Parent.AutoFilter.Range.Offset(1).Copy
must be replaced by the next one:
.Parent.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Copy
or
.Offset(1).SpecialCells(xlCellTypeVisible).Copy
which refers the processed range (`UsedRange'), starting from the second row.
What I am wanting is the copied data to be pasted to the first
available row in the target sheet.
You should define your available row to paste your fillered rows in, or first blank row in the sheet you want the filtered data pasted. Then you will be able to paste your data into that row.
In my example, I'm filtering my datawork (source sheet) sheet by anything in col 24 that contains "P24128" and pasting into "Sheet8" (Target sheet), in my example.
I actually don't want the header row copied, so all visible bar that
row
You also didnt want the headers. :)
Sub CopyFilteredDataSelection10()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Datawork")
ws.Activate
'Clear any existing filters
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'1. Apply Filter
ActiveSheet.Range("A1:ADU5000").AutoFilter Field:=24, Criteria1:="*P24128*" ' "*" & "P24128" & "*" ' im filtering by anything in col 24 that contains "P24128"
'2. Copy Rows minus the header
Application.DisplayAlerts = False
ws.AutoFilter.Range.Copy 'copy the AF first
Set Rng = ws.UsedRange.Offset(1, 0)
Set Rng = Rng.Resize(Rng.Rows.Count - 1)
Rng.Copy
'3. The Sheet & Where you want to paste the filtered data precisely into Sheet x (Sheet 8 in my example)
Sheets("Sheet8").Activate
lr = ThisWorkbook.Worksheets("Sheet8").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
Range("A" & lr).Select
ActiveSheet.Paste
Application.DisplayAlerts = True
'4. Clear Filter from original sheet
On Error Resume Next
ws.Activate
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
What does the not-including the headers is this
ws.AutoFilter.Range.Copy 'copy the AutoFilter first
Set Rng = ws.UsedRange.Offset(1, 0)
Set Rng = Rng.Resize(Rng.Rows.Count - 1)
Rng.Copy
& your target is after you activate the target sheet and find its last row
lr = ThisWorkbook.Worksheets("Sheet8").Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row + 1
I'm creating a VBA application with some forms. When the data is inserted into the Table, Column A calculates a value with a formula. After that I need to copy the resulting value (like paste special, values only) into the adjacent Row
I just need to know how to select the last row everytime. I have tried with ActiveCell, Find, Range etc. but none are working
Selection.Copy
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Try this:
Selection.Copy
ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).PasteSpecial Paste:=xlPasteValues
From a programming point of view, it's much better to define variables rather than using Selection, .select, or ActiveCell, etc... This code will place the cell you are looking for into the variable r, assuming the first header row (A1) is not empty. If you don't want to make any assumptions about the first or last row, see the last answer on this page. In the code below, this would mean replacing Set r = r.End(xlDown) with Set r = sh.Range("A:A").Find("*", Range("A1"), SearchDirection:=xlPrevious)
Option Explicit
Sub test()
Dim sh As Worksheet, r As Range
Set sh = ThisWorkbook.Worksheets("Sheet1")
Set r = sh.Range("A1")
Set r = r.End(xlDown)
r.Select 'remove after code has been tested and you know it works
End Sub
If you have more questions, just ask. There's a lot of help available to help you program in the proper way here on StackOverflow.
Thanks all,
I fixed it with help of both
LastValue = Range("Table1[Opportunity no.]").End(xlDown).Value
Set ws = Worksheets("Datos")
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
With ws
.Cells(iRow, 2).Value = LastValue
End With
I have written a code to loop though range of cells and copy certain data in a column. But everytime I run the code it just copies the last record and not all of them. The issue is somewhere in the destination line of code where it can't find the last unused cell. Any help will be very appreciated. Many Thanks.
Sub ImmoScout()
Dim MyRange As Range, Mycell As Range, Mycell2 As String
Set MyRange = Application.Selection
'Application.ScreenUpdating = False
For Each Mycell In MyRange
Mycell2 = Mycell.Value
Worksheets("Sheet1").Activate
Worksheets("Sheet1").AutoFilterMode = False
Range("A1:BB34470").AutoFilter Field:=54, Criteria1:=Mycell2
Range("AM1").Select
Range(Selection, Selection.End(xlDown)).Select
If Selection.Cells.Count < 1048576 Then
Selection.Copy Destination:=Range("BP1048576").End(xlUp).Offset(1, 0)
Range("AU1").Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Destination:=Range("BQ1048576").End(xlUp).Offset(1, 0)
End If
Next Mycell
' Application.ScreenUpdating = True
End Sub
You could use advanced filter:
Sheets("Emps").Range("A1:D8").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Emps").Range("F5:F6"), CopyToRange:=Range("A1:B1"), _
Unique:=False
Data source to selectively copy:
Data destination copied:
Reference this short YouTube video; You can record a marco to help yourself with the code also:
https://www.youtube.com/watch?v=bGUKjXmEi2E
A more thorough tutorial is found here:
http://www.contextures.com/xladvfilter01.html
This tutorial shows how to get the source data from outside Excel:
https://www.extendoffice.com/documents/excel/4189-excel-dynamic-filter-to-new-sheet.html
This tutorial shows how to split data values based on a column to different sheets (Fruit column; Apple sheet, Pear sheet, etc.):
https://www.extendoffice.com/documents/excel/2884-excel-save-filtered-data-new-sheet-workbook.html
Side note: your criteria needs the titles you are querying on just like the output needs the titles to know where to place the info. If it doesn't match correctly, Excel won't know what you mean. Don't forget to update the range name!
Before version:
After version:
Your code in this case is:
Sub yourFilter()
Range("Source").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"Sheet2!Criteria"), CopyToRange:=Range("Sheet1!Extract"), Unique:=False
End Sub
Avoid using Select and Activate which is not required when Autofiltering or copying a range. Instead declare some range variable, set it properly and use it.
After you have applied autofilter, maybe you are interested in copying the visible cells. Change the lines which are copying the ranges as below...
Range("AM1:AM34470").SpecialCells(xlCellTypeVisible).Copy
Range("AU1:AU34470").SpecialCells(xlCellTypeVisible).Copy
Also Selection.End(xlDown) is not very reliable, it will stop once it finds an empty cell if any before the last cell in the column.
I am currently working on an Excel VBA Macro script where in it will do a simple TRUE or False test to the active cell. My problem is, i cannot make this working until the end of the list. It only run once and ends the program. I need this VB script to perform the IF & ELSE test up to the bottom of the list.
Description of the problem:
Let's say i have a list of dates in A1 to A9999 and beside it (F1:F9999) there's also a list that has a text on it. the F1:F9999 list contains two values only. (a)SAME DATE and (b) NOT THE SAME.
Perform a True or False test in the List F1:F9999.
If the active cell value is equal to the text "SAME DATE" (TRUE), it will ignore and move to the next item in the list then perform again number 1.
If the active cell value is equal to the text "SAME DATE" (FALSE), it will insert a row above it and then move to the next item in the list then perform again number 1
The TRUE or FALSE test will run until the end of the list.
The TRUE or FALSE test will stop running if it reached the bottom of the list.
by the way, the number of items in the list is not consistent. I just put there F1:F9999 for example purposes.
here's my code!
Sub IFandElseTest()
If ActiveCell.Value = "Same Date" Then
Range(Selection, Cells(ActiveCell.Row, 1)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(1, 0).Select
Else:
ActiveCell.Offset(1, 0).Select
Range(Selection, Cells(ActiveCell.Row, 1)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End Sub
Appreaciate if you could help me on this.
Give this a try.
Explanation:
You should avoid using .Select/ActiveCell etc. You might want to see this LINK
When working with the last row, it's better not to hard code values but dynamically find the last row. You might want to see this LINK
Work with Objects, what if the current sheet is not the sheet with which you want to work with?
The below FOR loop will traverse the row from below and move up.
Code:
Sub Sample()
Dim ws As Worksheet
Dim LRow As Long, i As Long
Dim insertRange As Range
'~~> Chnage this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Work with the relevant sheet
With ws
'~~> Get the last row of the desired column
LRow = .Range("E" & .Rows.Count).End(xlUp).Row
'~~> Loop from last row up
For i = LRow To 1 Step -1
'~~> Check for the condition
'~~> UCASE changes to Upper case
'~~> TRIM removes unwanted space from before and after
If UCase(Trim(.Range("E" & i).Value)) = "SAME DATE" Then
'~~> Insert the rows
.Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
End With
End Sub
Screenshot:
Followup From Comments
It really worked! BUT, one final modification. in your code: Set ws = ThisWorkbook.Sheets("Sheet1") Is it possible is you can set the WS as the Active worksheet. The reason of this is because the name of the worksheet unique and not consistent also.
Like I mentioned, in the first link above as well in the comment, do not use Activesheet. Use CodeNames of the sheet which do not change. See the screenshot below.
Blah Blah is the name of the sheet which you see in the worksheet tab but Sheet1 is the CodeName which will not change. i.e. you can change the name of the sheet from Blah Blah to say Kareen but in the VBA editor, you will notice that the Codename doesn't change :)
Change the code
Set ws = ThisWorkbook.Sheets("Sheet1")
to
'~~> Replace Sheet1 with the relevant Code Name
Set ws = [Sheet1]
Edit:
If you leave out the r.copy line it does more or less exactly what Siddharth Rout's solution does
Sub insrow()
Dim v, r As Range
Set r = [d1:e1]
v = r.Columns(1).Value
Do
' r.copy
If v = "Same Date" Then r.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set r = r.Offset(1)
v = r.Columns(1).Value
Loop Until v = ""
End Sub
This does not yet include the end condition if row exceeds line 9999 but that should be easy to add ...