VBA-code does not look through hidden rows for adding a row with tracking number - vba

I have another question which I hope to resolve with your help.
What do I want to do.
I use Excel to track my work, activities, contacts, et cetera. While doing that I found I was doing a lot of repetitive work in adding rows at the end of a sheet called "Activities".
What I want to do is this:
- Press a button and adding a row.
- Increase the trackingnumber with 1
- Insert default values
The code.
To automate this, I have found (copy, pasted, adjusted it to my needs) the following code:
Sub AddRowActiviteiten_NewAtEnd()
'Add's a new row at the end of the sheet.
Dim wsActiviteiten As Worksheet
Set wsActiviteiten = Sheets("Activiteiten")
DefType = "Daily"
DefStatus = "Open"
DefIssue = "*****"
DefImpact = "*****"
DefPrio = "Laag"
MyDate = Date
wsActiviteiten.Range("A4").Value = "1"
'Copy the "One Row To Rule Them All"
wsActiviteiten.Range("A3:Q3").Copy
wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
'Stop the "copy-action"
Application.CutCopyMode = False
'Increase the tracking number with "one"
LastNumber = wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Value
wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = LastNumber + 1
'Insert default values
LastRow = wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(-1, 0).Row
Cells(LastRow + 1, 2) = DefType
Cells(LastRow + 1, 3) = DefStatus
Cells(LastRow + 1, 4) = DefIssue
Cells(LastRow + 1, 5) = DefImpact
Cells(LastRow + 1, 6) = DefPrio
Cells(LastRow + 1, 8) = MyDate
'Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
End Sub
The problem.
In this sheet I open new items, but I also close them. I do this by changing their status and hide them from view. And this is the point where it goes wrong. When I close the last item on the list and want to add a new row, the macro adds a new row below the last visible entry. It does not find the last entry I have just hidden. And also, when this happens, adding the default values to the new row does not work. It adds them at the row above the added one.
Somehow this makes perfect sense. I tell the macro to look for the last entry, but what I don't understand is why it looks at the last visible entry and why it does not look in the hidden rows.
To replicate. Copy the code into a sheet (maybe you need to change the name of the sheet) and add a few lines. Put some info in the last row and hide it. Add another few lines and see what happens.
The solution. Is there a way to resolve this? Maybe there is a smarter way of doing things? I looked into things, but mostly I got results using "("A" & Rows.Count).End(xlUp)". A loop could work, but I am afraid that 1) It does not search through hidden rows and 2) it makes the sheet (somewhat) sluggish. I must say I have tried to make a loop, first I want to see if my first solution is salvageable.
Thank you for your input, if there are any questions please let me know.
Simon
EDIT: Working code for anyone interested
Sub AddRowActiviteiten_NewAtEnd()
'Add's a new row at the end of the sheet.
Dim wsActiviteiten As Worksheet
Set wsActiviteiten = Sheets("Activiteiten")
DefType = "Daily"
DefStatus = "Open"
DefIssue = "*****"
DefImpact = "*****"
DefPrio = "Laag"
MyDate = Date
'Copy the One Row To Rule Them All
wsActiviteiten.Range("A3:Q3").Copy
'Offset(y,x)
'De -16 is een getal dat iets doet, maar ik weet niet wat.
wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(1, -16).PasteSpecial (xlPasteAll)
'Stop the "copy-action"
Application.CutCopyMode = False
'Het volgnummer verhogen met 1
'Het laatste getal selecteren (LastNumber) en dan plus 1.
LastNumber = wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(0, -16).Value
wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(1, -16).Value = LastNumber + 1
'Insert default values
LastRow = wsActiviteiten.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Offset(-1, 0).Row
Cells(LastRow + 1, 2) = DefType
Cells(LastRow + 1, 3) = DefStatus
Cells(LastRow + 1, 4) = DefIssue
Cells(LastRow + 1, 5) = DefImpact
Cells(LastRow + 1, 6) = DefPrio
Cells(LastRow + 1, 8) = MyDate
'Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
End Sub

Update
I see your sheet has an autofilter "hiding" the status rows - which Find wont detect, unlike hidden rows.
Suggest you try this updated code below:
Sub Test()
Dim rng1 As Range
If ActiveSheet.AutoFilterMode Then
MsgBox ActiveSheet.Range(Split(ActiveSheet.AutoFilter.Range.Address, ":")(1)).Row
Else
Set rng1 = Columns("A:A").Find("*", [a1], xlFormulas, , xlByRows, xlPrevious)
If Not rng1 Is Nothing Then MsgBox rng1.Row
End If
End Sub
initial post
If you are hiding rows then you can use Find with the xlFormulas option to find entries in hidden rows (unlike xlValues).
Dim rng1 As Range
Set rng1 = Columns("A:A").Find("*", [a1], xlFormulas, , xlByRows, xlPrevious)
MsgBox rng1.Address

Say we have a status column AB and we currently close an item by placing the word "Closed" in that column and then hiding the row.
Instead:
Unhide all rows
Perform any required inserts and edits
Via a loop, hide all rows marked "Closed"

Use this for getting the last row and it will see the last row, even if it is hidden.
LastRow = wsActiviteiten.UsedRange.Rows.Count

I've just found solution:
If you have at least one column in your range with 'consistent' data (all cells in that column are not empty/blank) you can use formula COUNTA and you can reference you code to value of that COUNTA formula.
For example:
Insert formula '=COUNTA(A1:A100000)' in 'B1' cell.
In B1 you will get how many rows you have they are hidden or not.
In your code change:
wsActiviteiten.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
to
wsActiviteiten.Range("A" & Range("B1").Value).Offset(1, 0).PasteSpecial (xlPasteAll)
Of course, if, for example, cell 'A2' is blank and this is the only blank cell you will need to adjust your formula to '=COUNTA(A1:A100000) +1'.
If you have more blank/empty cells and you don't know the exact number of them (blank cells have been changed dynamically) this method will not work.
As I said previously you need to have at least one column with 'consistent' data (with known number of empty cells in advance if any).

Related

How to move entire row based on text in a single cell?

I have been searching on the internet where to find the most efficient and simple way of the following:
I have a spreadsheet that contains 3 sheets:
information
training
Leavers
Within the information sheet, column B contains a validation text that is conditionally formatted. There are two validation options:
Active
Leaver
I want that once the cell value is changed from 'active' to 'Leaver' that the whole row would be removed from the sheet and moved to 'Leaver's sheet.
I have used the code below, it works, however if there is no Leavers it will transfer the first row of 'active'. Can anyone tell me what is the problem?
Sub AlexR688(x)
'For http://www.mrexcel.com/forum/excel-q...ific-text.html
'Using autofilter to Copy rows that contain centain text to a sheet called Errors
Dim LR As Long
Range("B2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Personal Information").Cells(Rows.Count, "B").End(xlUp).Row
LR1 = Sheets("Leavers").Cells(Rows.Count, "B").End(xlUp).Row + 1
With Sheets("Personal Informaiton").Range("B2:C" & LR)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="Leaver", _
Operator:=xlOr, Criteria2:=":Leaver"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("Leavers").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
Secondly, I want to make the same in the 'Training' sheet. But in there, column B, contains the same 'Active', 'Leavers' which is referenced from personal information. So, once the Personal information sheet column B is changed from 'active' to 'leaver', training sheet will change as well, but i want the row in the training sheet would be deleted.
Thirdly, if I accidentally moved row from Personal information sheet to Leavers sheet, is it possible that by selecting back to 'active' cell value the row would move back to where it was?
Thank you very much. Hope it is clear enough.
this is the easiest way
Private Sub imperecheaza_Click()
Dim ws As Worksheet
Dim Rand As Long
Set ws = Worksheets("BD_IR")
Rand = 3
Do While ws.Cells(Rand, 4).Value <> "" And Rand < 65000
If ws.Cells(Rand, 4).Value = gksluri.Value * 1 And ws.Cells(Rand, 5).Value = gksluri.List(gksluri.ListIndex, 1) * 1 Then
ws.Rows(Rand) = "" '(here you will delete entire Row)
gksluri.RemoveItem gksluri.ListIndex
Exit Do
End If
Rand = Rand + 1
Loop
End Sub

How to remove a certain value from a table that will vary in size in Excel

I'm new to the community and I apologize if there is a thread elsewhere, but I could not find it!
I'm currently diving into VBA coding for the first time. I have a file that I dump into a worksheet that currently I'm manually organizing and pushing out. When put into the worksheet, it delimits itself across the cells. This dump file will have varying row and column lengths every time I get it in a given day and dump into a work sheet. For example, one day it may be twenty rows and one day it may be thirty.
A certain roadblock in my VBA code creation process has presented itself. I'm trying to create a code that will parse through the worksheet to remove any time a certain value appears (See below image - I'm referring to the (EXT)). After doing so I'm trying to concatenate the cells in the row up until there is a space (which with the rows that have (EXT), there usually isn't a space after until the (EXT) is removed).
The code I made works for now but I recognize it's not very efficient and not reliable if the names extend longer than two cells. I was hoping someone on here could provide me with guidance. So, I'm looking for two things:
For the code to scan the whole active used range of the table and remove (EXT). As it may appear in various columns.
A way to concatenate the cells in every row in the active range from A to the cell before a blank cell
Keep in mind I have no coding background, I'm learning and I'm not familiar with VBA terms and whatnot all that much just yet - so if you could please explain in laymen's terms I'd appreciate it. I hope all of this makes sense... Thanks in advance!
This is just an example of part of what the dump code looks like, so my code probably doesn't match with the example below - I just wanted to provide a visual:
http://i.imgur.com/IwDDoYd.jpg
The code I currently have:
Sub DN_ERROR_ORGANIZER()
' Removes any (EXT) in Column 3 in actual dump data file
For i = 200 To 1 Step -1
If (Cells(i, 3).value = "(EXT)") Then
Cells(i, 3).Delete Shift:=xlToLeft
End If
Next i
' Removes any (EXT) in Column 4 in actual dump data file
For j = 200 To 1 Step -1
If (Cells(j, 4).value = "(EXT)") Then
Cells(j, 4).Delete Shift:=xlToLeft
End If
Next j
' Removes any (EXT) in Column 5 in actual dump data file
For k = 200 To 1 Step -1
If (Cells(k, 5).value = "(EXT)") Then
Cells(k, 5).Delete Shift:=xlToLeft
End If
Next k
' Places a new column before A and performs a concatenate on cells B1 and C1 to
' form a name, then copies all through column A1 to repeat on each row
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "=PROPER(CONCATENATE(RC[1],"", "", RC[2]))"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:A51")
Range("A1:A51").Select
End Sub
edited: to keep the comma after the first "name" only
this should do:
Sub main()
Dim cell As Range
With Worksheets("names")
With Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In .Rows
cell.Cells(1, 2).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(cell.Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
just remember to change "names" to you actual worksheet name
edited 2:
code for stopping cells to be processed at every line at the last one before the first blank one
Sub main()
Dim cell As Range, dataRng As Range
With Worksheets("names") '<--| change "names" to you actual worksheet name
Set dataRng = Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In dataRng.Columns(1).Cells
cell.Offset(, 1).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(.Range(cell, cell.End(xlToRight)).Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
With dataRng
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
I believe you are quite close to achieve what you are asking for and, based on your request, I will not give you a solution but some guidance to complete it by yourself.
First 3 loops: You could simplify by having a single set of nested loops: An outer loop running from 3 to 5, an inner loop running from 200 to 1; the outer loop will run over index, say "p", the inner over index, say "q", and your reference to cells would become Cells(q,p). If you need to run this over more than 3 rows, just start the outer loop from, say, 3 and till, say 10000 (being 10000 the maximal number of rows your data may display) and add a condition that if the first cell of the row is empty, you exit the outer loop.
The second part (this is what I understood) is to take the 2-3 first cells and concatenate them into a new cell (i.e. the column you add at the left). Once again, you can just loop over all your rows (much the same as in the outer loop mentioned above), except that now you will be looking at the cells in columns 2-4 (because you added a column at the left). The same exit condition as above can be used.
I'm not sure if this is what you were looking for, but this is what I understood you were looking for.
After reading user3598756's answer, I realized that I missed the boat with my original answer.
Sub DN_ERROR_ORGANIZER()
Dim Target As Range
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
With Target.Offset(0, Target.Columns.Count).Resize(, 1)
.FormulaR1C1 = "=PROPER(C1&"", ""&TEXTJOIN("" "",TRUE,RC[-" & (Target.Columns.Count - 1) & "]:RC[-1]))"
.Value = .Value
End With
Target.Delete
End Sub
UPDATE
If you are running an older version of Excel that doesn't support TEXTJOIN then use this:
Sub DN_ERROR_ORGANIZER()
Dim Data
Dim x As Long, y As Long
Dim Target As Range
Dim Text As String
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
Data = Target.Value
For x = 1 To Target.Rows.Count
Data(x, 1) = Data(x, 1)
For y = 2 To Target.Columns.Count
If Data(x, y) <> vbNullString Then Text = Text & " " & Data(x, y)
Next
If Len(Text) Then Data(x, 1) = Data(x, 1) & "," & Text
Text = vbNullString
Next
Target.ClearContents
Target.Columns(1).Value = Data
End Sub

Using VBA to Add Rows based on a cell value onto another worksheet

I am trying to create a spreadsheet whereby I have a value in a cell in a worksheet called "Equipment" cell C5, for example a Value of 4.
Starting Cell Image
I need to use this value to copy a section of the same row (D5:M5) and paste it that many times into a worksheet called "Programming" also if this changes I would like it to delete or add where required, ignoring where there is a blank or 0 value in the "equipment" sheet
Desired Result
I have around 30 different items and all will have different sections to copy but they will be of the same size. Also Could this look down a list of values all in the same column and do the same for all the values
I'm very new to VBA and have managed to hide and show tabs based on values but i'm struggling to get my head around this as it's a little too complicated at this point.
Thank You in advance
Lee
This is what I have so far, I have edited the code to what I believe is correct but it still isn't working
Sub copySheetCells()
'loop by each cell in column "C"
For i = 2 To Sheets("Equipment").Cells(Rows.Count, "C").End(xlUp).Row
'repeat copy x times (based on cell in column "C" value)
For j = 0 To (Sheets("Equipment").Cells(i, "C").Value - 1)
'define source range
Source = "D" & (i) & ":M" & (i)
'find last row on second sheet
lastRowS2 = Sheets("Hardware_Programming").Cells(Rows.Count, "A").End(xlUp).Row
'copy data
Sheets("Equipment").Range(Source).copy Destination:=Sheets("Hardware_Programming").Range("A" & lastRowS2 + 1)
Next j
Next i
'copy headers
Sheets("Equipment").Range("D1:M1").copy Destination:=Sheets ("Hardware_Programming").Range("A1:J1")
End Sub
I only get blank spaces, is anyone able to advise any further?
Here you go, use this macro. Based on names Programming and Equipment as originally requested.
Sub copySheetCells()
'loop by each cell in column "C"
For i = 2 To Sheets("Programming").Cells(Rows.Count, "C").End(xlUp).Row
'repeat copy x times (based on cell in column "C" value)
For j = 0 To (Sheets("Programming").Cells(i, "C").Value - 1)
'define source range
Source = "D" & (i) & ":M" & (i)
'find last row on second sheet
lastRowS2 = Sheets("Equipment").Cells(Rows.Count, "A").End(xlUp).Row
'copy data
Sheets("Programming").Range(Source).copy Destination:=Sheets("Equipment").Range("A" & lastRowS2 + 1)
Next j
Next i
'copy headers
Sheets("Programming").Range("D1:M1").copy Destination:=Sheets("Equipment").Range("A1:J1")
End Sub
EDIT
Please avoid copying the code from the answer and posting it back at your question, I replaced the Sheet1 with Programming so you can rename that sheet in your workbook.
Macro seems to do what it does, the quantity in Sheet1/Programming was not provided (column "C" according to your initial requirements):
Source (with added quantity)
Result:
Hope this will solve your problem :)
For i = 1 To 30 Step 1
If Sheets("Equipment").Cells(1 + 4, 3).Value > 0 Then
Sheet1.Range(Cells(i + 3, 5), Cells(i + 3, 13)).Copy
For j = 1 To Sheet1.Cells(1 + 4, 3).Value Step 1
LR = Sheets("Programming").Cells(Sheets("Programming").Rows.Count, "A").End(xlUp).Row
Sheets("Programming").Range("A" & LR + 1).PasteSpecial Paste:=xlPasteValues
Next
End If
Next
Cheers ;)

Excel VBA User form entry to a specific range inside worksheet

So I am currently trying to have a user input some information and put that information in a specific range based on what values in the dropdown list are selected. For example, I selected Monday, so I want the information to go in the Range A1:A12, but if they select Tuesday then go to range G1:G12.
Also, if the range is already full with data, I'd like for it to tell the user that it is full. Do not have any example code, but here is a psuedo-code example
Private Sub cbSubmit_Click()
range("A2").Select
ActiveCell.End(xlDown).Select
lastrow = ActiveCell.Row
MsgBox lastrow
If ComboBox1.Value = "Monday" Then
Cells(lastrow + 1, 1).Value = tb1.Text
Cells(lastrow + 1, 2).Value = tb2.Text
End If
If ComboBox1.Value = "Tuesday" Then
range("G2").Select
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
Cells(lastrow2 + 1, 1).Value = tb1.Text
Cells(lastrow2 + 1, 2).Value = tb2.Text
End If
End Sub
Also, in the above code, is there a better way to find the last cell in the range that is blank? This one only works if there is already data in the range and that's not always the case.
And also check some sort of CountA or something to see if the range is already full of data. Thanks in advance!
I will answer just so I can demonstrate code better.
As I said in the comments, if you want to check each value in a range, you can do so like this:
Dim c
For Each c in Range("A1:A10") 'Whatever your range to check is
If c <> vbNullString Then
'Found Data - not empty
Exit For
End If
Next
If you're just checking 2 cells as it looks like you are, you should probably just use:
If Cells(lastrow2 + 1, 1) <> vbNullString and Cells(lastrow2 + 1, 2) <> vbNullString
If you just want to add the data to the bottom of the list, your code is already getting the last row and adding to it ... so each time you call this:
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
It is getting the last row and the rest of your code adds it to the end.
One more thing. You should really replace this:
range("G2").Select
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
With this:
lastrow2 = range("G2").End(xlDown).Row
You should avoid using select as often as possible.
In my experience, it is really only necessary when displaying a different sheet.

Runtime Error 1004 using Select with several workbooks

I have an Excel workbook which pulls out data from two other workbooks.
Since the data changes hourly there is the possibility that this macro is used more than one time a day for the same data.
So I just want to select all previous data to this date period and want to delete them.
Later on the data will be copied in anyway.
But as soon as I want to use
WBSH.Range(Cells(j, "A"), Cells(lastRow - 1, "M")).Select
the code stopes with Error 1004 Application-defined or object-defined error.
Followed just a snippet of the code with the relevant part.
What is wrong here?
'Set source workbook
Dim currentWb As Workbook
Set currentWb = ThisWorkbook
Set WBSH = currentWb.Sheets("Tracking")
'Query which data from the tracking files shoud get pulled out to the file
CheckDate = Application.InputBox(("From which date you want to get data?" & vbCrLf & "Format: yyyy/mm/dd "), "Tracking data", Format(Date - 1, "yyyy/mm/dd"))
'states the last entry which is done ; know where to start ; currentWb File
With currentWb.Sheets("Tracking")
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
lastRow = lastRow + 1
End With
'just last 250 entries get checked since not so many entries are made in one week
j = lastRow - 250
'Check if there is already data to the look up date in the analyses sheet and if so deletes these records
Do
j = j + 1
'Exit Sub if there is no data to compare to prevent overflow
If WBSH.Cells(j + 1, "C").Value = "" Then
Exit Do
End If
Loop While WBSH.Cells(j, "C").Value < CheckDate
If j <> lastRow - 1 Then
'WBSH.Range(Cells(j, "A"), Cells(lastRow - 1, "M")).Select
'Selection.ClearContents
End If
Thank you!
Actually you can't use Select for on Range on a Sheet which is not selected/activated. Select only works on the active worksheet.
You should have something like
WBSH.Activate
before
WBSH.Range(Cells(j, "A"), Cells(lastRow - 1, "M")).Select
WBSH.Range(WBSH.Cells(j, "A"), WBSH.Cells(lastRow - 1, "M")).Select
Take a look here: Selecting and activating Cells
NOTE: Avoid using Select as much as you can
EDIT: To clear the content (As asked in the comments), you should use someting like
WBSH.Range(WBSH.Cells(j, "A"), WBSH.Cells(lastRow - 1, "M")).Clear
instead of (I imagine)
WBSH.Range(Cells(j, "A"), Cells(lastRow - 1, "M")).Clear
because the cells in your range needs to be qualified.
You can use Clear which deletes the formatting of the cell and the value in that cell, and ClearContent which deletes only the value in the cell.
Note that you can use With:
With WBSH
.Range(.Cells(j, "A"), .Cells(lastRow - 1, "M")).Clear
End With