I have made a simple macro assigned to a hotkey to select the current region and then remove the header row. The problem is that the ranges we work with are often full of blank cells which prevent the selector from capturing the entire table dependant on the activecell.
I thought about maybe simply creating a loop, offsetting the ActiveCell and trying again until it hits an illegal range, but I have a bad feeling about this approach.
Sub multieditSelect()
Dim tbl As Range
If ActiveCell.Value = "" Then
MsgBox "Select a cell with something in it, you bastard"
Exit Sub
End If
Call startNoUpdates
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Select
Call endNoUpdates
Selection.Copy
End Sub
Is there a way to make this more reliable?
Edit: Let me add further complication/detail to this problem...
We work with a database and editing records en masse requires exporting them into excel, and the copy/pasting them back into the web interface, so it is common for us to be working with numerous tables of different size, using a worksheet like a notepad to store and modify them.
I want to create a sub that will select the current region irrespective of where it lies on the worksheet, quite possibly this is the third or fourth table to have been pasted onto the same sheet.
This makes going by the last column or last row too inflexible. CurrentRegion is ideal were it not for it's occasional failure to detect the table... so I suppose I need to build my own version of CurrentRegion that will overcome it's shortcomings.
Edit2: I've come up with a lazy solution.
Since these tables will always have a header, I'll just have the activecell offset up till it hits something, and hopefully that will be the header if an empty column is the starting point.
I think this will still be unreliable should there be a pocket of cells surrounded by empty cells in the middle of the table.
Sub multieditSelect2()
Dim tbl As Range
On Error GoTo errmsg
startNoUpdates
Do While ActiveCell.Value = ""
ActiveCell.Offset(-1, 0).Activate
Loop
startNoUpdates
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Select
endNoUpdates
Selection.Copy
Exit Sub
errmsg:
endNoUpdates
errMsgBox = MsgBox("Couldn't find a table!", vbCritical, "Error!")
End Sub
Edit3: Here is an example of where my code calls down:
I would like it to be able to capture the table even in this scenario where a cell in the test region is the activecell... but how?
Additional to my comment, see if this helps improve your logic (see comments in code for more details):
Sub multieditSelect()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1") 'use a variable for the sheet you want to use
Dim tbl As Range
Dim lRow As Long, lCol As Long
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row 'last row at column 1
lCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column 'last column at row 1
Set tbl = ws.Range(ws.Cells(2, l), ws.Cells(lRow, lCol)) 'Set the range starting at row 2, column 1, until last row, last col
Call endNoUpdates(tbl) 'pass your range as a parameter if you require this specific range in your other sub
tbl.Copy Destination:=tbl.Offset(0, 20) 'copy 20 columns to the right
'Alternative
ws.Range("W1").Resize(tbl.Rows.Count, tbl.Columns.Count).Value = tbl.Value 'copy values to specific range
End Sub
Sub endNoUpdates(tbl As Range)
'do something with this range, i.e.:
Debug.Print tbl.address
End Sub
Related
I am trying to select a specific range of data and delete only the cells I identify, not the entire row.
I have included the coding that I currently have. I am trying to select everything to the left of the indicated cell, delete the range, and shift all cells up. I cannot input a specific range (ie. Range("B3:B7").delete, etc.) as the range will be changing throughout the code. I need it to be a dynamic range that will change as the code runs.
Worksheets("Sheet1").Select
Cells(2, 6).Select
ActiveCell.Offset(0, 1).Select
col = ActiveCell.Column
row = ActiveCell.Row
Cells(row, col).Select
Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
Range.Delete Shift:=xlToUp
Let me know if you need any more information. Code will run up until I hit the last line (Range.Delete).
Thanks in advance.
I think this is what you are looking for. When you select any single cell, this line of code will select the range from column A and the active row, to the active column + 1 on the active row.
ThisWorkbook.Sheets("Sheet1").Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, ActiveCell.Column + 1)).Delete
I can't write it for you. But consider this technique since you seem to be doing this manually. Application.Inputbox is a built in userform that pauses the code execution until you review the range / craft your own selection.
Dim xrng As Range
Dim rngholder As Range
Dim xArray(0 To 20) As Variant
Dim x As Integer
Set xrng = Application.Selection
Set xrng = Application.InputBox("Title", "Make a selection", xrng.Address, Type:=8)
x = 0
'If xrng = "" Then Exit Sub
For Each rngholder In ActiveSheet.Range(xrng.Address)
If rngholder.Value > "" Then
xArray(x) = VBA.Trim(rngholder.Value)
Else
End If
x = x + 1
Next rngholder
In this case the Inputbox is loaded with the active cell or whatever the selection was when the macro was called and the range is populated into an array. Where you can customize this is on the line set 'xrng =' line. I would put 'set xrng = the logic to get that selection you've described so everything to the left, and up, and delete it.
edit:
Set xrng = Range(ActiveCell, Range(ActiveCell.End(xlToLeft), ActiveCell.End(xlUp))).Select
You can figure this out with a little more research into ranges. If you chose this answer you'll have an interface to handle exceptions manually, and since it seems to me you're doing this somewhat by eye, its a compromise you might benefit from in actual use.
I have a workbook with multiple sheets.
Every sheet with data has a common column, K, which contains Client Manager names.
In Sheet2 I have used a Data Validation field in C1 using a list, so creating a drop down where I can select a Client Manager.
So if I select Charlie Brown, and run a macro, I would like all sheets to be filtered to only show Charlie Brown’s data.
I am an absolute VBA beginner, so I have harassed Mr Google mercilessly – the majority of suggestions involve hard-coding the filter value, rather than making it a variable cell value.
The best I have found is this:
Sub apply_autofilter_across_worksheets()
Dim xWs As Worksheet
On Error Resume Next
For Each xWs In Worksheets
xWs.Range("K").AutoFilter 1, CLng(Sheets("Sheet2").Range("C1").Value)
Next
End Sub
When I run the macro:
• Positive - no error!
• Negative - nothing happens
I'm not sure what this does: xWs.Range("K") - the original script had a number after the column letter, but no matter what number I put after it, it makes no difference.
I also simply typed a Client Manager name into C1, with no impact. So clearly it's just all busted.
There are 8 data worksheets, plus Sheet2. The number of columns vary sheet to sheet, but none are more than AZ.
Any help would be greatly appreciated please!
As mentioned in the comments, On Error Resume Next hides errors, but does not deal with them. Using Clng definitely causes an error - this would try to convert the value in C2 to type Long when you're dealing with a String. Also, you need to specifically not filter Sheet2.
How about something like this? (assumes your data begins in A1 on each Sheet.)
Edited to only autofilter visible sheets.
Sub apply_autofilter_across_worksheets()
Dim ws As Worksheet
Dim clientManager As String
Dim lastCol As Long, lastRow As Long
Dim filterRng As Range
clientManager = Sheets("Sheet2").Range("C1").Value
For Each ws In Worksheets
If ws.Name <> "Sheet2" And ws.Visible Then
With ws
If .AutoFilterMode Then .AutoFilter.ShowAllData
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set filterRng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
filterRng.AutoFilter 11, clientManager
End With
End If
Next ws
End Sub
I have the example where I want to write a VBA statement which will select all data in a single column, there are no blanks in the column data. The column position will never change e.g. column A, and the data starts in row 3. However the total number of rows in the column will change regularly.
I want the system to dynamically select all the cells in column and then I can run a method against these selected pieces of data.
As an example of performing an action on your range without selecting it:
Public Sub Test()
Dim rColA As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rColA = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp))
MsgBox "Column A range is " & rColA.Address 'Delete if you want.
rColA.Interior.Color = RGB(255, 0, 0) 'Turn the back colour red.
rColA.Cells(2, 1).Insert Shift:=xlDown 'Insert a blank row at second cell in range
'So will insert at A4.
'If the first cell in your range is a number then double it.
If IsNumeric(rColA.Cells(1, 1)) Then
rColA.Cells(1, 1) = rColA.Cells(1, 1) * 2
End If
End With
End Sub
Try
Dim LastRow as Long, sht as worksheet
Set sht = ThisWorkbook.Worksheets("My Sheet Name")
LastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
sht.Range("A3:A" & LastRow).Select
Like Darren Bartrup-Cook says, you may not need to select the data, you can almost always perform actions directly which is much faster.
If your column is "isolated" meaning no other nonblank cells touch your data you can use:
Range("firstCellInYourColumn").CurrentRegion.Select
(this works the same way as Ctrl+* from keyboard)
otherwise use:
Range(Range("firstCellInYourColumn"), Range("firstCellInYourColumn").End(xlDown)).Select
both will work if there are really no blanks within your data.
You should also prepend all Range with worksheet expression, I omitted this.
New to VBA
I'm confused as to why I need to run my module twice to get it to update my cells. My code:
Option Explicit
Sub m_Range_End_Method()
Dim lRow As Long
Dim lCol As Long
Dim currentRow As Long
Dim i As Integer
Dim rng As Range
Set rng = ActiveCell
Range("B:B").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("MySheet").Select
' Loop Through Cells to set description in each cell
Do While rng.Value <> Empty
currentRow = ActiveCell.Row
If InStr(rng.Value, "PETROL") = 0 Then
Set rng = rng.Offset(1)
rng.Select
Else
Worksheets("MySheet").Cells(currentRow, 5) = "Shopping"
Worksheets("MySheet").Cells(currentRow, 6) = "Car"
Set rng = rng.Offset(1)
rng.Select
End If
Loop
End Sub
On the first run what happens in Excel 2016 is that Column B gets highlighted and that's it. I then have to press "Run" again in visual basics editor for it to then update all the entries at which point column B gets unselected. All I want to do is update the cells at the currentRow of a specified worksheet. I've been reading but have got myself into some confusion, someone said I should use the
Range("B:B").Select
statement and for some reason the spreadsheet update works but only if I run it twice. Without this Range command, for reasons I don't understand, the spreadsheet doesn't update - all that happens is that the box selection moves to entries with Petrol and stays there with the program running but not updating.
The aim of the program is to find in a sheet all occurrences of a word in column B, in this initial case that is PETROL (I'm going to expand to include many others). For that match on the same row I want it to update columns 5 and 6 with descriptions. The excel spreadsheet will have hundreds of rows of entries with varying descriptions in column B.
Any help would be much appreciated.
I guess you have to run it twice because the first time you run it, the ActiveCell could be anything, and your loop depends on it not being empty to start with, but after the first run you have selected column B (and other things)...
Read this previous answer on avoiding the use of Select and Activate, it will make your code more robust: How to avoid using Select in Excel VBA macros
Revised Code
See the comments for details, here is a cleaner version of your code which should work first time / every time!
Sub m_Range_End_Method()
Dim col As Range
Dim rng As Range
Dim currentRow As Long
' Use a With block to 'Fully Qualify' the ranges to MySheet
With ThisWorkbook.Sheets("MySheet")
' Set col range to the intersection of used range and column B
Set col = Intersect(.UsedRange, .Columns("B"))
' Loop through cells in col to set description in each row
For Each rng In col
currentRow = rng.Row
' Check upper case value match against upper case string
If InStr(UCase(rng.Value), "PETROL") > 0 Then
.Cells(currentRow, 5) = "Shopping"
.Cells(currentRow, 6) = "Car"
End If
Next rng
End With
End Sub
The problem that I'm facing is concerning Excel. I'm trying to extract rows with multiple columns out of sheets based on certain criteria. I've found some solutions regarding this, but nothing is really what I'm looking for or I can't change it to make it work. I'll try to explain the issue more detailed below using an example.
Situation:
8 sheets (named Sh1 to Sh8) with a list of tasks
Each sheet represents a kind of task (personal, work, ...)
Each sheet has the same format
Data is located starting from row 4 and between column A to K
Below the data is a row with total calculations
The data includes text, numbers and blank cells
Column D is the status of the task (C for completed, I for in progress, N for not started)
Style of the sheets is completely done by using conditional formatting
I would like something that checks those 8 sheets and copies all entries (including the blank cells) that are a certain status, being either C, I or N, to a new sheet, called "Filtering". The filtering sheet will have headers as well and the data should start at row 7.
When I started this, I came up with a formula (based on this) that copies all the entries of one sheet. I could filter it by putting C, I or N in the cell D4 on the filtering sheet.
{
=IFERROR(
INDEX(
Sh1!A$4:A$19;SMALL(
IF(
Sh1!$D$4:$D19=Filtering!$D$4;
ROW(Sh1!A$4:A$19)-ROW(Sh1!A$4)+1
);
ROWS(Sh1!A$4:Sh1!A4)
)
);
"")
}
As I said before, the data includes blank cells, so I changed the formula to the following to make sure the blank cells didn't turn into 0's:
{
=IFERROR(
IF(
INDEX(SAME AS ABOVE)="";
"";
INDEX(SAME AS ABOVE);
);
"")
}
Although this worked, I could only perform this on one sheet, and not on all eight. I could solve this by starting Sh2 at a lower row in the filtering sheet and do this for all other sheets, but that's not really what I'd like to get. I would really like to get to a continuous list that sums up all the not started, completed or in progress by changing that one cell D4 on the filtering sheet.
That's where I would like your suggestions. If it's possible to do this without VBA, I'd prefer that, since I sometimes use it in the online web application and macro's don't work there. If VBA is the only solution, obviously that'd be okay too.
On a side note: I tried VBA based on a code that I found here. (please have patience with me, I never coded before this) but it seems really slow to process this. Every time I run the macro, it takes more than 15 seconds to calculate this, although there are only 200 tasks that I currently have. The following was for getting all the completed tasks. I could easily make the others by changing the C to I or N. There was another problem where the whole sheet was removed, including my headers, so I'd have to put a range on the clear.
Sub ExtractList()
Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim columnD As Range
Dim c As Range
Dim count As Long
Set destinationWorksheet = ActiveWorkbook.Worksheets("Filtering")
destinationWorksheet.Cells.ClearContents
count = 1
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Sh1" Or ws.Name = "Sh2" Or ws.Name = "Sh3" Or ws.Name
= "Sh4" Or ws.Name = "Sh5" Or ws.Name = "Sh6" Or ws.Name = "Sh7" Or
ws.Name = "Sh8" Then
Set columnD = ws.Range("D:D") 'columnD
For Each c In columnD
If WorksheetFunction.IsText(c.Value) Then
If InStr(c.Value, "C") > 0 Then
c.EntireRow.Copy
destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
count = count + 1
End If
End If
Next c
End If
Next ws
End Sub
Thanks already for reading through this and I'm looking forward to your suggestions.
Cheers,
Bart
The reason your code is taking too long to run is because you are looping through the entire column. You need to delimit the range to work with.
This solution:
• Allows the user to determine the extraction criteria using cell D4 in “Filtering” worksheet (Target)
• Sets the data ranges for each worksheet [Sh1, Sh2, Sh3, Sh4, Sh5, Sh6, Sh7, Sh8] (Source)
• Uses AutoFilter to select the data required and
• Posts the resulting ranges from all worksheets in the “Filtering” worksheet
It assumes that:
• All worksheets involved have the same structure and headers
• Headers are located at A6:K6 for Target worksheet and A3:K3 for Source worksheets (change as required)
Sub ExtractList()
Dim wshTrg As Worksheet, wshSrc As Worksheet
Dim sCriteria As String
Dim rDta As Range
Dim rTmp As Range, rArea As Range, lRow As Long
Rem Set Worksheet Target
Set wshTrg = ThisWorkbook.Worksheets("Filtering") 'change as required
Rem Clear prior data 'Header at row 6 & data starts at row 7 - change as required
With wshTrg
Rem Sets Criteria from Cell [D4] in target worksheet
sCriteria = .Cells(4, 4).Value2
.Cells(7, 1).Value = "X" 'To set range incase there is only headers
.Range(.Cells(7, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents
End With
Rem Process each worksheet
lRow = 7
For Each wshSrc In ThisWorkbook.Worksheets
Select Case wshSrc.Name
Case "Sh1", "Sh2", "Sh3", "Sh4", "Sh5", "Sh6", "Sh7", "Sh8"
With wshSrc
Rem Clear AutoFilter
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Rem Set Data Range
Set rDta = .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 11))
End With
With rDta
Rem Apply AutoFilter
.AutoFilter Field:=4, Criteria1:=sCriteria
Rem Set resulting range
Set rTmp = .Offset(1).Resize(-1 + .Rows.count).SpecialCells(xlCellTypeVisible)
Rem Clear Autofilter
.AutoFilter
End With
Rem Post Resulting range in target worksheet
For Each rArea In rTmp.Areas
With rArea
wshTrg.Cells(lRow, 1).Resize(.Rows.count, .Columns.count).Value = .Value2
lRow = lRow + .Rows.count
End With: Next: End Select: Next
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Range Object (Excel), Range.Offset Property (Excel),
Range.SpecialCells Method (Excel),
Select Case Statement, Worksheet.AutoFilter Property (Excel),
Worksheet.AutoFilterMode Property (Excel), With Statement