Here I go again, another simple Function that I cannot seem to find anywhere.
instead, i see other related discussions/codes but they are more complex that how i need it.
I have Three Pivot tables, they are connected via a slicer so when i select one Item, all of them will be filtered in the same parameter.
I would only want to hide the blank rows between a two Pivot table that are blank, excluding 1 rows for each to allow for viewing separation. I tried to use a Recording macro but seems like there's no way i can expect the relative Reference mode to help on this when i use xlUp and xlDown.
in the attached image is sample of what are the blank rows that will be hidden.
Thank you so much in advance!
Sub HideBlanks()
Dim nRow
' First, show all rows
Cells.EntireRow.Hidden = False
' Then go from the last row to the third one,
For nRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row To 3 Step -1
' check that several columns of that row are blank (Cells(nRow, 1) = "" And Cells(nRow, 2) = "" And Cells(nRow, 3) = "" )
' and also check that the row above is blank also (And Cells(nRow - 1, 1) )
If Cells(nRow, 1) = "" And Cells(nRow, 2) = "" And Cells(nRow, 3) = "" And Cells(nRow - 1, 1) = "" Then
' If so, hide the row
Cells(nRow, 1).EntireRow.Hidden = True
End If
Next nRow
End Sub
Related
There is a question similar to this one but it does not meet the specifications here.
I have a MultiSelect ListBox and a table which represents an AdvancedFilter criteria.
I want to populate the column "Level" of this table with all the values selected from the ListBox, every value should be in a separate row (OR condition for an AdvancedFilter).
The results I am seeking :
If no item is selected, it should remove the rows added in the table and only populate "<>0".
The code I have written so far does the tricks shown in the 2 first images but and when I deselect all the items it does not work anymore:
Private Sub ListBox1_LostFocus()
Dim aArray() As Single
ReDim aArray(1 To 1) As Single
With ListBox1
For I = 0 To .ListCount - 1
If .Selected(I) Then
aArray(UBound(aArray)) = .List(I)
ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
End If
Next I
End With
Range(Cells(3, "S"), Cells(UBound(aArray) - 1, "S"))= Application.Transpose(aArray)
End Sub
Has someone already dealt with this issue? Any help would be much appreciated! Thank you so much!
I think this will do what you want. As per my comment about preloading with "<>0" - that's not possible because your array is a Single. So you need to trap it. Also, I tweaked your range to write to as in my mock up I kept getting a zero on the end if 1 or more were selected.
Dim aArray() As Single
ReDim aArray(1 To 1) As Single
With ListBox1
For I = 0 To .ListCount - 1
If .Selected(I) Then
aArray(UBound(aArray)) = .List(I)
ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
End If
Next I
End With
Range("S3:S10").ClearContents ' change this range to suit
If UBound(aArray) = 1 Then
Range("S3") = "<>0"
Else
Range(Cells(3, "S"), Cells(3 + UBound(aArray) - 2, "S")) = Application.Transpose(aArray)
End If
It looks complicated, but it does the job neatly.
Private Sub ListBox1_LostFocus()
'
'is called when you finish selecting items from the ListBox
'
Dim aArray() As Single
ReDim aArray(1 To 1) As Single
'fetch selected items of listbox into aArray
With ListBox1
For I = 0 To .ListCount - 1
If .Selected(I) Then
aArray(UBound(aArray)) = .List(I)
ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
End If
Next I
End With
'clear old items in the advanced filter's condition table to replace them with those we fetched
'/!\ if there was more old items than new items, we would need to delete their rows from the table
Range("Condition[Level]").ClearContents
'we need to compare the size of the array with the size of the table so that we don't have extra rows
'(the advanced filter interpretates empty rows as '*' so we absolutely need to get rid of them)
r = UBound(aArray)
n = Range("Condition[#Data]").Rows.count
If UBound(aArray) = 1 Then
Range("Condition[Level]") = "<>0" 'if nothing is selected, fetch every item meaning numeric and non numeric (more powerful than "*")
Range("Condition[Serial]") = "*" 'columns to the left of 'Level' are not automatically replicated in the table (contrary to those on the right which gets previous row's) values so they become empty, that's why we need to fill them with the value we want
Range("Condition[#Data]").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
Else
Range(Cells(3, "S"), Cells(3 + UBound(aArray) - 2, "S")) = Application.Transpose(aArray)
If n > r - 1 Then
[Condition].Rows(r & ":" & n).Select ' r+1 to skip the headers' row
[Condition].Rows(r & ":" & n).Delete 'doing a select before the delete prevents a bug which would delete the entire rows of the sheet
End If
End If
If you have an improvement to my code, i will gladly take it! I am slightly new to VBA, i'm sure there are tons of ways to improve it.
If you have a request similar to this issue, feel free to ask any question.
I have files of data with the following format:
In column A, identifiers occur either doubly (e.g. 302_60) or singularly (e.g.310_58). Additional information is present in column B.
What I want to do is:
tag the rows that have single identifiers in column A with
TRUE/FALSE in Column C
for any TRUE tag, insert a line BELOW
copy into the inserted row the contents of the ENTIRE tagged row (here just columns A,B)
I solved #1 using =COUNTIF(A:A, A1)=1
I then wrote a VBA script to solve #2
Sub ins_below_and_copy()
Dim c As Range
For Each c In Range("C1:C100")
If InStr(1, c, "TRUE", vbTextCompare) > 0 Then
Rows(c.Offset(1, 0).Row & ":" & c.Offset(1, 0).Row).Insert Shift:=xlDown
End If
Next c
End Sub
Achieving the desired end result (#3)
seems simple enough, right? I have been trying .Copy and .Paste commands, but keep getting type-mismatch errors, an error that does not make sense to me (since I am not a competent VBA coder). Any ideas?
You have down all the hard work, filling in the gaps is easy. Select the two columns, HOME > Editing - Find & Select, Go To Special..., Blanks, OK, =, UP and Ctrl+Enter.
You can run this after you have your empty rows created.
Dim sheet As String
Dim lastRow As Long
sheet = "SheetName"
lastRow = Sheets(sheet).Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lastRow 'Assuming you have a Header Row
If Sheets(sheet).Cells(r, 1) = "" Then
Sheets(sheet).Cells(r - 1, 3) = "FALSE"
Sheets(sheet).Cells(r, 1) = Sheets(sheet).Cells(r - 1, 1)
Sheets(sheet).Cells(r, 2) = Sheets(sheet).Cells(r - 1, 2)
Sheets(sheet).Cells(r, 3) = Sheets(sheet).Cells(r - 1, 3)
End If
Next r
I'm trying to get excel to put together a series of text strings that haven't been formatted systematically, so that they end up split into different rows on a data sheet.
I'm aware this might've been solved elsewhere so sorry for that but I'm struggling to describe the issue, and I can't post images on it but basically it's
Column 1 with a list of the entries, and
Column 2 with text strings that are spread over 2 or more rows
Is it possible to write some kind of formula or macro that would be able to check the first column and then stitch together all entries in the second column going down until it found a new entry in the first column? I've got a feeling it might be possible using some sort of loop thing with index functions, but I've no idea where to start even.
Thanks,
Mike
Mike give this a ty
Sub appendValues()
'The sub is designed to loop through code and when ever there is a null value and column a it will take the value of what is in column B and appended to the row above it and delete the row.
Dim row As Integer
row = 1
'This code starts with row one but this can be changed at will.
Do Until ThisWorkbook.Sheets("sheet1").Cells(row, 2).Value = ""
'loop statement is designed to continue to Loop until there is a null value inside of you the value in the second column.
If ThisWorkbook.Sheets("sheet1").Cells(row, 1).Value = "" Then
ThisWorkbook.Sheets("sheet1").Cells(row - 1, 2).Value = ThisWorkbook.Sheets("sheet1").Cells(row - 1, 2).Value & ThisWorkbook.Sheets("sheet1").Cells(row, 2).Value
Rows(row).Delete
Else
'else statement is needed because there is an implied looping by decreasing the total number of rows after the delete.
row = row + 1
End If
Loop
End Sub
Sub appendValues()
'The sub is designed to loop through code and when ever there is a null value and column a it will take the value of what is in column B and appended to the row above it and delete the row.
Dim row As Integer
row = 1
'This code starts with row one but this can be changed at will.
Do Until ThisWorkbook.Sheets("sheet1").Cells(row, 2).Value = ""
'loop statement is designed to continue to Loop until there is a null value inside of you the value in the second column.
If ThisWorkbook.Sheets("sheet1").Cells(row, 1).Value = "" Then
ThisWorkbook.Sheets("sheet1").Cells(row - 1, 2).Value = ThisWorkbook.Sheets("sheet1").Cells(row - 1, 2).Value & ThisWorkbook.Sheets("sheet1").Cells(row, 2).Value
Rows(row).Delete
Else
'else statement is needed because there is an implied looping by decreasing the total number of rows after the delete.
row = row + 1
End If
Loop
End Sub
I need to write a spreadsheet which when you press a button adds a row of data and asks for the parameters needed for the calculations, but I cant seem to get it to fill in the data in the next row down? I am a complete begginner to macros in excel and have only done very basic programming for matlab on my uni course.
My script so far is as follows:
Sub AddPosTol()
' AddPosTol Macro
Dim rngSeek As Range
Set rngSeek = Range("B1")
While rngSeek <> ""
'If the cell isn't empty, drop down one row:
rngSeek = rngSeek.Offset(1, 0)
End
With rngSeek.Offset(0, 1)
With .Font
.Name = "Solid Edge ANSI1 Symbols"
.Size = 11
.Value = 1
End With <--added this
End With
'don't need to call Range() around rngSeek - it is already a range type
rngSeek.Offset(0, 3) = "=RC[-1]"
rngSeek.Offset(0, 4) = "0"
With rngSeek.Offset(1, 1)
.Font.Bold = True <--don't really need a With if only one statement
End With
'can use a With statement here if you want:
With rngSeek
.Offset(1, 1) = "X value"
.Offset(2, 1) = "Y Value"
.Offset(0, 4) = "=2*SQRT((R[1]C[-3]-R[1]C)^2+(R[2]C[-3]-R[2]C)^2)"
.Offset(0, 5) = "=2*SQRT((R4C3-R[1]C)^2+(R5C3-R[2]C)^2)"
.Offset(0, 6) = "=2*SQRT((R[1]C[-3]-R[1]C)^2+(R[2]C[-3]-R[2]C)^2)"
.Offset(0, 7) = "=2*SQRT((R[1]C[-3]-R[1]C)^2+(R[2]C[-3]-R[2]C)^2)"
.Offset(0, 8) = "=2*SQRT((R4C3-R[1]C)^2+(R5C3-R[2]C)^2)"
.Offset(0, 2) = (InputBox("Insert Positional Tolerance Diametre"))
.Offset(1, 2) = (InputBox("Insert X value on drawing"))
.Offset(2, 2) = (InputBox("Insert Y value on drawing"))
End With
End Sub
OK, I'm going to refactor your code a bit to make it more readable, and try and answer your question too.
Firstly, I believe that lastrow = Worksheets("Sheet1").Rows.Count will return the number of rows in the worksheet, not the number of rows you have currently filled in. When I ran that line I got back 1048576! To find the first empty row, we need to find a column that will definitely have a value filled in for each row; then, cycle down that column looking for an empty cell: this is your first empty row:
Dim rngSeek as range
set rngSeek = Range("A1") <--your starting cell
While rngSeek <> ""
'If the cell isn't empty, drop down one row:
rngSeek = rngSeek.Offset(1, 0)
Wend
'rngSeek is now sitting at the first row that has a blank in column A
So this technique will find us the first row we are looking for. Then, we just populate that row with the data. You can leverage other elements from the code snippet above to make things easier when updating: specifically, the .offset method:
Your code:
With rngSeek.offset(0, 2)
With .Font
.Name = "Solid Edge ANSI1 Symbols"
.Size = 11
End With
.value = 1
End With
'repeat for all cells: no need to select them first, just use .offset
FYI .Offset goes like so:
Range("Cell Reference").Offset(rows, columns)
Where 'Cell Reference' can be any cell, like 'A1' or 'D24', rows is the number of rows to offset to the right (use negative number to offset to the left), and columns is the number of columns to offset down (use negative to offset up). So a value of .offset(0, 0) offsets to nowhere.
EDIT: You may not use column A to seek the first blank cell; if so, adapt the offset values to reflect which cell you want to change the value of. A value of 1 will offset one column right or one row down, and -1 will offset one column left or one row up.
ADDITION: It will be better to use Range("A1").End(xlDown) instead of the loop to find the first blank cell. Set the range variable equal to this, and replace the loop with:
set rngSeek = Range("A1").End(xlDown).Offset(1, 0)
You can then use rngSeek the way described above. (you can rename rngSeek to any variable name also).
Ive written a macro that takes some source data and writes it onto several sheets, which id like to remain hidden before and after the macro has run. Having written the Macro, when I run it it only updates a few records on each sheet (for instance on the first hidden sheet it updates 21 rows out of over 1000. What is the reason for this happening? Surely it should update them all or none of them? Im not getting any errors either. Ive tried
Application.ScreenUpdating = False
Worksheets("FT Raw").Visible = True
Worksheets("L1").Visible = True
Worksheets("L2").Visible = True
Worksheets("L3").Visible = True
Worksheets("L4").Visible = True
But still only 21 rows get updated.
Update: This is the code that is running on each sheet
endval = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To endval
If Not Sheets("FT Raw").Cells(i, "A") = "" Then
splitted = Split(Sheets("FT Raw").Cells(i, "A"), ",")
Sheets("FT Raw").Cells(i, "B") = splitted(0)
Sheets("FT Raw").Cells(i, "C") = splitted(1)
Sheets("FT Raw").Cells(i, "D") = splitted(2)
If Sheets("FT Raw").Cells(i, "D") = "1" Then
Sheets("L1").Cells(j, "A") = Trim(splitted(0))
Sheets("L1").Cells(j, "B") = Trim(splitted(3))
j = j + 1
End If
End If
Next i
Ok Edit. You need to specify the Sheet("FT Raw") in your endval calc.
Try this set endval = Sheets("FT Raw").Cells(Sheets("FT Raw").Rows.Count, 1).End(xlUp).Row and proceed with the remainder of your code.
(You could also use endval = Sheets("FT Raw").UsedRange.Rows.Count only if you don't have blank cells at the top of the column)
Lucky last, you don't have to unhide these sheets at all to run the code. By all means do so to debug but when running in anger it's not necessary.
This has nothing to do with the hiding of sheets - even if a sheet is hidden, you can still modify it with VBA. (Only if it is protected, you need to unprotect it.)
Lookig at your code, I do not see, where j is initialized - and under which circumstances column D in your sheet FT rawis equal to "1".
I suggest you initialize j in the top, e.g. if you want to add the rows using
j = Sheets("L1").Range(Rows.Count, 1).End.(xlUp).Row + 1
Then, after running the macro (for a check), filter column D in your raw sheet with an Autofilter for the value 1 and see if that matches the number of entries in sheet L1.