View Full Version : row selection
stefan0901
03-04-2009, 02:07 AM
I have an excel sheet with data in rows and columns. I would like to create a macro which select every row which has "empjj" as value for column K.
At this moment, I have made the folowing macro:
Sub Test1()
Dim i As Integer
Dim r
Dim n
Set r = Range("A1").CurrentRegion
For i = 1 To r.Rows.Count
If Cells(i, 11).Value = "EmpJJ" Then
Cells(i, 11).EntireRow.Select
End If
Next i
End Sub
The problem is that excel select each row succesively, but not all of them at the same time.
Is there anybody who can help me?
Bob Phillips
03-04-2009, 02:19 AM
Sub Test1()
Dim i As Integer
Dim r As Range
Dim n As Range
Set r = Range("A1").CurrentRegion
For i = 1 To r.Rows.Count
If Cells(i, 11).Value = "EmpJJ" Then
If n Is Nothing Then
Set n = Cells(i, 11)
Else
Set n = Union(n, Cells(i, 11))
End If
End If
Next i
If Not n Is Nothing Then n.EntireRow.Select
End Sub
JONvdHeyden
03-04-2009, 02:20 AM
Why do you want to select the rows? What are you going to do with the selection?
Consider using a filter, which is more efficient than a loop if the range is considerably large, e.g:
Sub FilterEmpJJ()
Dim rRng1 As Range, rRng2 As Range
rRng1 = Range("K1", Range("K" & Rows.Count).End(xlUp))
rRng2 = Range("K2", Range("K" & Rows.Count).End(xlUp))
With rRng1
.AutoFilter field:=1, Criteria1:="EmpJJ"
rRng2.SpecialCells(xlCellTypeVisible).EntireRow.Select
'.AutoFilter
End With
End Sub
stefan0901
03-04-2009, 03:04 AM
I want to delete these rows. I tried both of your codes and they work very good. Thank you. Is it also possible to select the rows where the value of a column (e.g. 'K') starts with the letter "a" ?
Bob Phillips
03-04-2009, 03:11 AM
ub Test1()
Dim i As Integer
Dim r As Range
Dim n As Range
Set r = Range("A1").CurrentRegion
For i = 1 To r.Rows.Count
If LCase(Cells(i, "K").Value) Like "a*" Then
If n Is Nothing Then
Set n = Cells(i, "K")
Else
Set n = Union(n, Cells(i, "K"))
End If
End If
Next i
If Not n Is Nothing Then n.EntireRow.Delete
End Sub
JONvdHeyden
03-04-2009, 04:09 AM
Or using autofilter:
Sub FilterEmpJJ()
Dim rRng1 As Range, rRng2 As Range
rRng1 = Range("K1", Range("K" & Rows.Count).End(xlUp))
rRng2 = Range("K2", Range("K" & Rows.Count).End(xlUp))
With rRng1
.AutoFilter field:=1, Criteria1:="a*"
rRng2.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End Sub
Hello
Can I make a request on this thread to adapt for my own use.If so I would like to
Select all rows with EmpJJ (or my word) maybe a 100 rows and copy the lot & then paste to a new sheet.
One comment is that I could not get JONvdHeyden code to run. It stops on rRng1 = Range("K1", Range("K" & Rows.Count).End(xlUp)) with the message Run Time error 91. Object variable or with block variable not set.
Any help much appreciated
Thank you
Bob Phillips
10-13-2009, 09:07 AM
You should be able to adapt this
Sub CopyData()
Const SHEET_SOURCE As String = "Sheet2" '<<<< change to suit
Const SHEET_TARGET As String = "Sheet4" '<<<< change to suit
Const COLUMN_SOURCE As String = "F" '<<<< change to suit
Const WORD_TO_TEST As String = "MyWord" '<<<< change to suit
Dim LastRow As Long
Dim rng As Range
With Worksheets(SHEET_SOURCE)
LastRow = .Cells(.Rows.Count, COLUMN_SOURCE).End(xlUp).Row
Set rng = .Cells(1, COLUMN_SOURCE).Resize(LastRow)
rng.AutoFilter field:=1, Criteria1:=WORD_TO_TEST
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
rng.EntireRow.Copy Worksheets(SHEET_TARGET).Range("A1")
End If
rng.AutoFilter
End With
End Sub
Hello XLD
Thank you for the reply. This works fine in a macro used once but if I try to insert it later to filter out another word in a row i.e. NEW, EXISTS, DONOR etc I get the error message Compile Error duplicate declaration in current scope.I have attached an edited file with the macro in module 6.
Hope it makes sense what I want to do.
Bob Phillips
10-13-2009, 12:19 PM
Not really Gil. Can you post the workbook as is, with the error?
Had a bit of trouble with the attachment but it is there now.
Not really Gil. Can you post the workbook as is, with the error?
Hello xld
Sorry for the delay but have been away for a while. Can you look at my attachment and point me in the error of my ways.
Thanks
Gil
mdmackillop
10-25-2009, 05:43 AM
Hi Gil,
1. Always use Option Explicit
2. You are declaring constants twice. Delete this lot near the end of your sub. Just change the value as required
Const SHEET_SOURCE = "Edited1" '<<<< change to suit
Const SHEET_TARGET As String = "EXISTS" '<<<< change to suit
Const COLUMN_SOURCE As String = "A" '<<<< change to suit
Const WORD_TO_TEST As String = "EXISTS" '<<<< change to suit
Dim LastRow As Long
Dim rng As Range
3. This sheet does not exist
Sheets("Jumpering Schedule").Select
4. A bit neater
Dim ws
Dim ShNames, s
ShNames = Array("Edited", "NEW", "EXITS", "DONOR", "Lic to d", "e to bar pair")
For Each s In ShNames
Set ws = Sheets.Add
ws.Name = s
Next
Hello mdmackillop
I have ammended attachment to the 3 points you made. The macro now runs & filters from edited and pastes into the 'NEW' sheet. I now need to include the next sheets filtering out the exists,donor etc but I dont know about the Option Explicit.Please help
Gil
2093
mdmackillop
10-25-2009, 08:11 AM
I've cleared out a lot of the excess code created by recording and then you just need a simple loop to filter and copy the data.
Option Explicit requires the declaration of variables and helps prevent errors.
Option Explicit
Sub MPFFiltering1()
'
' MPFFiltering Macro
Dim ws As Worksheet
Dim ShNames, s
Dim wsSource As Worksheet
Dim FiltRng As Range
Dim Tgts, t
Dim rng As Range
Const COLUMN_SOURCE As String = "A" '<<<< change to suit
ShNames = Array("EDITED", "NEW", "EXISTS", "DONOR", "LIC to D", "E to BAR PAIR")
For Each s In ShNames
Set ws = Sheets.Add
ws.Name = s
Next
Set wsSource = Sheets("Edited")
Sheets("Filter Schedule").Cells.Copy wsSource.Range("A1")
With wsSource
.Activate
.Rows("2:15").Delete
With .Cells
.Font.Bold = False
.Borders.LineStyle = xlNone
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
End With
With .Range("A1:I1")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.UnMerge
End With
.Columns("E:E").ColumnWidth = 18
With .Rows("1:1").Font
.FontStyle = "Regular"
.Size = 16
End With
.Columns(6).Delete
.Columns(4).Delete
.PageSetup.PrintArea = ""
With .PageSetup
.LeftFooter = "Edited"
.CenterFooter = "&F &A"
.RightFooter = "&P of &N"
End With
Set rng = .Columns("A:G")
End With
Tgts = Array("NEW", "EXISTS", "DONOR")
For Each t In Tgts
rng.AutoFilter field:=1, Criteria1:=t
On Error Resume Next
Set FiltRng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not FiltRng Is Nothing Then
FiltRng.EntireRow.Copy Worksheets(t).Range("A1")
End If
rng.AutoFilter
Next
End Sub
Hello mdmackillop
You have really helped with this problem I have been working on. The whole problem is almost resolved. You have shown how some tedious keyboard entries can be made to look very neat and tidy. The last 2 requests are to add the footer for each sheet and to set column widths for each sheet.
Many thanks
Gil
mdmackillop
10-25-2009, 12:18 PM
For Each t In Tgts
rng.AutoFilter field:=1, Criteria1:=t
On Error Resume Next
Set FiltRng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not FiltRng Is Nothing Then
FiltRng.EntireRow.Copy Worksheets(t).Range("A1")
End If
rng.AutoFilter
With Sheets(t).PageSetup
.LeftFooter = t
.CenterFooter = "&F &A"
.RightFooter = "&P of &N"
End With
Sheets(t).Columns("A:I").EntireColumn.AutoFit
Next
Hello mdmackillop
As ever there is always one who wont go away. I have some headings (not column) that would be in row A1, B1 & D1. I want to cut and paste into the "header left middle right" sections in that order and repeat on each sheet. The row can then remain blank and does not need deleting.
This really is nearly the end for this one
Gil
2118Hello mdmackillop
Me again. Last is that I want to be able to change the font size to 10 from 8 in all of the inserted sheets & autofit the columns. I have tried but it has me stumped Nothing else will be required so shall I then close it as solved even though I tagged on to someone else's thread.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.