I would like to have a macro that can search for multiple Items and copy the rows then paste into another spreadsheet.
Need to Search Column C.
If Any cell in that column = "Monitor", "Laptop", "Desktop", "Server", then copy those rows and paste in "C:\Testing.xlsx" Sheet1 Next available row.
Any help would be great thanks.
c.a.
[vba]Sub FiltersAndCopy()
Dim rngdBase As Range 'source table
Dim rngDataRange As Range 'data in source table
Dim lRow As Long 'last no empty row in target table
Dim rngSource As Range 'filters rows
Dim MyArray As Variant
Dim i As Integer
Dim MySheet As Worksheet ' sheet with source table (must be active!)
Dim StatusMode As Boolean
Dim Wkb As Workbook 'targets workbook
Const TARGETFILE As String = "C:\Testing.xls"
MyArray = Split("Monitor,Laptop,Desktop,Server", ",")
Set MySheet = ActiveSheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If IsOpenWrkbk(FileName(TARGETFILE)) Then
Set Wkb = Workbooks(FileName(TARGETFILE))
Wkb.Activate
End If
If Wkb Is Nothing Then
If IsExistFile(TARGETFILE) Then
Set Wkb = Workbooks.Open(FileName:=TARGETFILE)
Else
Set Wkb = Workbooks.Add
Wkb.SaveAs FileName:=TARGETFILE
End If
End If
'PRESUPPOSITION: source table starts in first row (in $A$1)
Set rngdBase = MySheet.Range("C1").CurrentRegion
With rngdBase
Set rngDataRange = .Offset(1, 0).Resize(.Rows.Count - 1) ', .Columns.Count)
End With
If MySheet.AutoFilterMode Then MySheet.AutoFilter.Range.AutoFilter 'deactivate autofilter
StatusMode = Application.DisplayStatusBar
Application.DisplayStatusBar = True
For i = LBound(MyArray) To UBound(MyArray)
Application.StatusBar = "Please wait... (" & i + 1 & "/" & UBound(MyArray) + 1 & ")"
rngdBase.AutoFilter _
Field:=3, _
Criteria1:=MyArray(i)
On Error Resume Next
Set rngSource = rngDataRange.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
If Not rngSource Is Nothing Then
lRow = LastNoEmptyCell(Wkb.Worksheets(1).UsedRange).Row
rngSource.Copy Wkb.Worksheets(1).Cells(lRow + 1, 1)
End If
Set rngSource = Nothing
lRow = 0
Next i
With Application
.ScreenUpdating = False
.EnableEvents = False
.StatusBar = False
.DisplayStatusBar = StatusMode
End With
rngdBase.AutoFilter
Set Wkb = Nothing
MsgBox "Ready"
End Sub
Private Function LastNoEmptyCell(Rng As Range, Optional Last_In_Row As Boolean = True) As Range
'Last_In_Row = True (or omitted) <- last cell in rows
'Last_In_Row = False <- last cell in columns
Dim LookOut As Byte
With Rng
If WorksheetFunction.CountA(.Cells) > 0 Then
If Last_In_Row Then
LookOut = xlByRows
Else
LookOut = xlByColumns
End If
Set LastNoEmptyCell = .Cells.Find(What:="*", _
After:=.Cells(1, 1), _
SearchOrder:=LookOut, _
SearchDirection:=xlPrevious)
Else
Set LastNoEmptyCell = .Cells(1, 1)
End If
End With
End Function
Private Function IsExistFile(FullPath As String) As Boolean
IsExistFile = Not (Dir(FullPath) = "")
End Function
Private Function IsOpenWrkbk(Wkb As String) As Boolean
Dim WkbTmp As Workbook
On Error Resume Next
Set WkbTmp = Workbooks(Wkb)
If WkbTmp Is Nothing Then
IsOpenWrkbk = False
Else
IsOpenWrkbk = True
End If
On Error GoTo 0
Set WkbTmp = Nothing
End Function
Private Function FileName(FName As String) As String
Dim i As Integer
i = InStrRev(FName, Application.PathSeparator)
FileName = Mid(FName, i + 1)
End Function[/vba]
Artik
That code is giving me an error '1004'
That command cannot be used on multiple selections.
It highlights
[VBA]
rngSource.Copy Wkb.Worksheets(1).Cells(lRow + 1, 1)
[/VBA]
any ideas?
I tested this code on XL2003. I haven't got XL2007.
I do not know where problem lies.
BTW. Replace[vba]Const TARGETFILE As String = "C:\Testing.xls"[/vba]on[vba]Const TARGETFILE As String = "C:\Testing.xlsx"[/vba]
Artik
Last edited by Artik; 01-01-2009 at 01:37 PM.
Yes I noticed that too and made the change.
Thanks for the help.
Can anyone see why this would work in Excel 2003 and not in 2007?
Another version, which copy row by row.
Add declaration in procedure FiltersAndCopy[vba]Dim rngDataRow As Range[/vba]and replace loop[vba]For i = LBound(MyArray) To UBound(MyArray)
'...
Next i[/vba]on this[vba] For i = LBound(MyArray) To UBound(MyArray)
Application.StatusBar = "Please wait... (" & i + 1 & "/" & UBound(MyArray) + 1 & ")"
rngdBase.AutoFilter _
Field:=3, _
Criteria1:=MyArray(i)
On Error Resume Next
Set rngSource = rngDataRange.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
If Not rngSource Is Nothing Then
If lRow = 0 Then
lRow = LastNoEmptyCell(Wkb.Worksheets(1).UsedRange).Row
End If
For Each rngDataRow In rngSource
rngDataRow.Copy Wkb.Worksheets(1).Cells(lRow + 1, 1)
lRow = lRow + 1
Next rngDataRow
Set rngSource = Nothing
End If
Next i[/vba]
I apologize for my english language.
Is bad, very bad. (It sounds as: "Bond, James Bond")
Artik
Ok it seems to work, but it does it copies it twice, do you know why. This is the code I am using.
Did some very minor changes.
[VBA]Sub FiltersAndCopy()
Dim rngdBase As Range 'source table
Dim rngDataRow As Range
Dim rngDataRange As Range 'data in source table
Dim lRow As Long 'last no empty row in target table
Dim rngSource As Range 'filters rows
Dim MyArray As Variant
Dim i As Integer
Dim MySheet As Worksheet ' sheet with source table (must be active!)
Dim StatusMode As Boolean
Dim Wkb As Workbook 'targets workbook
Const TARGETFILE As String = "C:\Testing.xlsx"
MyArray = Split("Monitor,Laptop,Desktop,Server", ",")
Set MySheet = ActiveSheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If IsOpenWrkbk(FileName(TARGETFILE)) Then
Set Wkb = Workbooks(FileName(TARGETFILE))
Wkb.Activate
End If
If Wkb Is Nothing Then
If IsExistFile(TARGETFILE) Then
Set Wkb = Workbooks.Open(FileName:=TARGETFILE)
Else
Set Wkb = Workbooks.Add
Wkb.SaveAs FileName:=TARGETFILE
End If
End If
'PRESUPPOSITION: source table starts in first row (in $A$1)
Set rngdBase = MySheet.Range("D10").CurrentRegion
With rngdBase
Set rngDataRange = .Offset(1, 0).Resize(.Rows.Count - 1) ', .Columns.Count)
End With
If MySheet.AutoFilterMode Then MySheet.AutoFilter.Range.AutoFilter 'deactivate autofilter
StatusMode = Application.DisplayStatusBar
Application.DisplayStatusBar = True
For i = LBound(MyArray) To UBound(MyArray)
Application.StatusBar = "Please wait... (" & i + 1 & "/" & UBound(MyArray) + 1 & ")"
rngdBase.AutoFilter _
Field:=4, _
Criteria1:=MyArray(i)
On Error Resume Next
Set rngSource = rngDataRange.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
If Not rngSource Is Nothing Then
If lRow = 0 Then
lRow = LastNoEmptyCell(Wkb.Worksheets(1).UsedRange).Row
End If
For Each rngDataRow In rngSource
rngDataRow.Copy Wkb.Worksheets(1).Cells(lRow + 1, 1)
lRow = lRow + 1
Next rngDataRow
Set rngSource = Nothing
End If
Next i
With Application
.ScreenUpdating = False
.EnableEvents = False
.StatusBar = False
.DisplayStatusBar = StatusMode
End With
rngdBase.AutoFilter
Set Wkb = Nothing
MsgBox "Ready"
End Sub
Private Function LastNoEmptyCell(Rng As Range, Optional Last_In_Row As Boolean = True) As Range
'Last_In_Row = True (or omitted) <- last cell in rows
'Last_In_Row = False <- last cell in columns
Dim LookOut As Byte
With Rng
If WorksheetFunction.CountA(.Cells) > 0 Then
If Last_In_Row Then
LookOut = xlByRows
Else
LookOut = xlByColumns
End If
Set LastNoEmptyCell = .Cells.Find(What:="*", _
After:=.Cells(1, 1), _
SearchOrder:=LookOut, _
SearchDirection:=xlPrevious)
Else
Set LastNoEmptyCell = .Cells(1, 1)
End If
End With
End Function
Private Function IsExistFile(FullPath As String) As Boolean
IsExistFile = Not (Dir(FullPath) = "")
End Function
Private Function IsOpenWrkbk(Wkb As String) As Boolean
Dim WkbTmp As Workbook
On Error Resume Next
Set WkbTmp = Workbooks(Wkb)
If WkbTmp Is Nothing Then
IsOpenWrkbk = False
Else
IsOpenWrkbk = True
End If
On Error GoTo 0
Set WkbTmp = Nothing
End Function
Private Function FileName(FName As String) As String
Dim i As Integer
i = InStrRev(FName, Application.PathSeparator)
FileName = Mid(FName, i + 1)
End Function
[/VBA]
1. Paste this code to standard module.[vba]Sub CurrRegAddress()
MsgBox "Address of D10 current region: " & Range("D10").CurrentRegion.Address
End Sub[/vba]
2. Activate sheet with source table
3. Run procedure CurrRegAddress.
What address you see?
Artik
It gives "Address of D10 current region: $A$9:$O$2995"
In mine Excel your code happen correctly.
I think, that your Excel has gone mad.
I do not know where problem lies.
Artik
Basically it does the job but paste it twice by list So it would do this
Monitor..........CNU532.........1
Monitor..........CNU532.........1
Desktop.........ABC123.........3
Desktop.........ZXY543.........2
Desktop.........ABC123.........3
Desktop.........ZXY543.........2
It does each ("MyArray") twice before going to the next one.
Hope that helps find the problem.
Are you not repeating data in source table?
Artik
Could it be because it can be looking at D9 that i believe if filtered will show all. So it would grab it twice. Can we make sure it looks at D10 and Down Nothing before D10?
Please attach fragment yours table, because I don't understand your last post.
Artik
Basically The List begins from D10 and up so Do if this is using a filter it would be filtered from D9. So if this is grabing data from D9 it would include everything in that column correct? I could be wrong, im just trying to make sure the code just grabs data from D10-D2995. How can we change the range from before. How you understand.
Your post is hard to understand the translation (automatic translation), because show me sheet with table. Attach sheet or screenshot, please.
Artik
Emoncada,Originally Posted by Emoncada
Could you post your current workbook, or an accurate (to current wb) sample workbook? I agree w/Artik. It is difficult to understand what is "happening" (or more accurately, not happening) without seeing it.
Thank you in advance,
Mark
GTO
Why you don't sleep at this time (03:37 am)?
Artik
Hey Artik,
I am beat, but insomnia sometimes... Am off to the rack shortly, you have a great afternoon.
Makr
Emoncada
Sometimes, one screenshot says more than thousand words.
Artik
Posting Permissions
Reply With Quote
