Solved: Find Copy Row and Paste

[Emoncada]

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.

[Artik]

c.a. :cool:
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
Artik

[Emoncada]

That code is giving me an error '1004'
That command cannot be used on multiple selections.

It highlights

rngSource.Copy Wkb.Worksheets(1).Cells(lRow + 1, 1)


any ideas?

[Artik]

I tested this code on XL2003. I haven't got XL2007.
I do not know where problem lies.

BTW. ReplaceConst TARGETFILE As String = "C:\Testing.xls"onConst TARGETFILE As String = "C:\Testing.xlsx"
Artik

[Emoncada]

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?

[Artik]

Another version, which copy row by row.

Add declaration in procedure FiltersAndCopyDim rngDataRow As Rangeand replace loopFor i = LBound(MyArray) To UBound(MyArray)
'...
Next ion this 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
I apologize for my english language.
Is bad, very bad. (It sounds as: "Bond, James Bond"):rotlaugh:

Artik

[Emoncada]

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.

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

[Artik]

1. Paste this code to standard module.Sub CurrRegAddress()
MsgBox "Address of D10 current region: " & Range("D10").CurrentRegion.Address
End Sub
2. Activate sheet with source table
3. Run procedure CurrRegAddress.

What address you see?

Artik

[Emoncada]

It gives "Address of D10 current region: $A$9:$O$2995"

[Artik]

In mine Excel your code happen correctly.
I think, that your Excel has gone mad. ;)

I do not know where problem lies.:(

Artik

[Emoncada]

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.

[Artik]

Are you not repeating data in source table?

Artik

[Emoncada]

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?

[Artik]

Please attach fragment yours table, because I don't understand your last post :(.

Artik

[Emoncada]

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.

[Artik]

Your post is hard to understand the translation (automatic translation), because show me sheet with table. Attach sheet or screenshot, please.

Artik

[GTO]

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.

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

[Artik]

GTO
Why you don't sleep at this time (03:37 am)? :)

Artik

[GTO]

Hey Artik,

I am beat, but insomnia sometimes... Am off to the rack shortly, you have a great afternoon.

Makr

[Artik]

Emoncada


It is difficult to understand what is "happening" (or more accurately, not happening) without seeing it.Sometimes, one screenshot says more than thousand words.:yes

Artik

[Emoncada]

I attached an example sheet. It's practically identical except for a lot of the stuff in the first rows. Not important. Hope this helps.

[Artik]

Emoncada

:haha:Kill you, it too not enough. :rotlaugh:
Hidden column F is culprit.

I return to my first propose. Did some minor changes.
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
Dim rngHiddenColumns As Range
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 9th row (in $A$9)
Set rngdBase = MySheet.Range("D10").CurrentRegion
With rngdBase
Set rngDataRange = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
'temporary unhide columns
For i = rngdBase.Column To rngdBase.Columns.Count + 1
If MySheet.Columns(i).Hidden Then
MySheet.Columns(i).ColumnWidth = 1
If Not rngHiddenColumns Is Nothing Then
Set rngHiddenColumns = Excel.Union(rngHiddenColumns, MySheet.Columns(i))
Else
Set rngHiddenColumns = MySheet.Columns(i)
End If
End If
Next i
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
lRow = LastNoEmptyCell(Wkb.Worksheets(1).UsedRange).Row
rngSource.Copy Wkb.Worksheets(1).Cells(lRow + 1, 1)
Set rngSource = Nothing
End If
lRow = 0
Next i
'deactivate autofilter
rngdBase.AutoFilter
'hide temporary unhide columns
rngHiddenColumns.EntireColumn.Hidden = True
'width columns in target table is the same as in source table
For i = rngdBase.Column To rngdBase.Columns.Count + 1
With ActiveSheet
.Columns(i).ColumnWidth = MySheet.Columns(i).ColumnWidth
End With
Next i
With Application
.ScreenUpdating = False
.EnableEvents = False
.StatusBar = False
.DisplayStatusBar = StatusMode
End With
Set Wkb = Nothing
MsgBox "Ready"
End SubPlus rest procedures (functions).

:ole:
Artik

[Emoncada]

Artik I appreciate all your hard work in this one.
It works Perfectly now.
Once Again Thank You!!!