Solved

Copy Rows from another workbook based on Criteria

Posted on 2015-02-23
12
674 Views
Last Modified: 2016-02-10
Hi,

I am looking for a VBA solution that will execute a macro from the "Destination Workbook". What it must do is:

1. Open the testdata.xls workbook
2. Filter the data based on the string in Cell B2 of the "destination workbook.xls".
3. Copy all visible rows including the header row to the sheet "Raw Data" in the destination workbook.
4. Close the testdata.xls workbook.

The end result would be that the column headers and only all rows that contain what is in cell B2 now: "Copperville", in Column C of the testdata.xls workbook are copied to the "raw data" sheet of the "destination workbook.xls".

The example has only 5 columns of data in the "testdata.xls" workbook but that will vary so ideally the solution should capture however many columns of data exist and copy those to the "raw data" sheet of the "destination workbook.xls".

Thanks in advance,

swjtx99
Destination-Workbook.xls
testdata.xls
0
Comment
Question by:swjtx99
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 4
  • 2
  • +1
12 Comments
 
LVL 34

Expert Comment

by:Norie
ID: 40627306
If you moved the criteria, ie Cooperville, to A2 you could use advanced filter.
Sub FilterData()
Dim wbSrc As Workbook
Dim rngCrit As Range
Dim rngDst As Range
Dim rngData As Range

    Set rngCrit = ThisWorkbook.Sheets("Criteria").Range("A1:A2")
    
    Set rngDst = ThisWorkbook.Sheets("Raw Data").Range("A1")
    
    Set wbSrc = Workbooks.Open(ThisWorkbook.Path & "\testdata.xls")
    
    Set rngData = wbSrc.Sheets(1).Range("A1").CurrentRegion
    
    rngData.AdvancedFilter xlFilterCopy, rngCrit, rngDst
    
    wbSrc.Close SaveChanges:=False
      
End Sub

Open in new window

0
 
LVL 22

Expert Comment

by:Flyster
ID: 40627335
See if this works for you:

Sub CopyData()
Dim destrng As Range
destdata = Range("B1").Value
  Workbooks.Open Filename:= _
    "C:\Enter\Path\Here\testdata.xls"
      Columns("C:C").Select
        Selection.AutoFilter
          ActiveSheet.Range("$C$1:$C$2579").AutoFilter Field:=1, Criteria1:= _
            destdata
              Cells.Select
                Range("C1").Activate
                  Selection.Copy
                  Windows("Destination-Workbook.xls").Activate
                Sheets("Raw Data").Select
              Range("A1").Select
            ActiveSheet.Paste
          Application.DisplayAlerts = False
        Windows("testdata.xls").Activate
      ActiveWorkbook.Close savechanges:=False
    Application.DisplayAlerts = True
  Range("A1").Select
End Sub

Open in new window

Just change line "C:\Enter\Path\Here\testdata.xls" to you current path.

Flyster
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 40627342
Hi, here's a VBS version that you can run outside of Excel, from a VBS file.

strDestination = "C:\Temp\Scripts\Excel\New\Destination-Workbook.xls"
strData = "C:\Temp\Scripts\Excel\New\TestData.xls"

Const xlUp = -4162
Const xlToLeft = -4159
Const xlFormulas = -4123
Const xlWhole = 1
Const xlByRows = 1
Const xlNext = 1
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objDest = objExcel.Workbooks.Open(strDestination, False, False)
Set objData = objExcel.Workbooks.Open(strData, False, False)
strFindString = objDest.Sheets("Criteria").Cells(1, "B").Value
Set objRawData = objDest.Sheets("Raw Data")
Set objSheet = objData.Sheets(1)
intLastCol = objSheet.Cells(1, 256).End(xlToLeft).Column
Set rngHeader = objSheet.Range(objSheet.Cells(1, 1), objSheet.Cells(1, intLastCol))
Set rngSearch = objSheet.Range("C1:C" & objSheet.Cells(65536, 1).End(xlUp).Row)
Set objFoundCell = rngSearch.Find(strFindString, objSheet.Range("C1"), xlFormulas, xlWhole, xlByRows, xlNext, False)
If Not objFoundCell Is Nothing Then
	rngHeader.Copy objRawData.Range("A1")
	strFirstAddress = objFoundCell.Address
	Do
		objSheet.Range(objSheet.Cells(objFoundCell.Row, 1), objSheet.Cells(objFoundCell.Row, intLastCol)).Copy objRawData.Cells(objRawData.Cells(65536, 1).End(xlUp).Row + 1, 1)
		Set objFoundCell = rngSearch.FindNext(objFoundCell)
	Loop While Not objFoundCell Is Nothing And objFoundCell.Address <> strFirstAddress
End If
objData.Close False
MsgBox "Done"

Open in new window


Regards,

Rob.
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:swjtx99
ID: 40627349
H Norie,

Thanks for your reply. I see that your solution does work if the criteria is in A2 but I need the flexibility to use a cell besides A2. Ideally any cell could contain the criteria.  

I  tried changing the first line to .Range("B2") and it copied every line over. Perhaps lines that do not contain the criteria in column C could be deleted after the copy?

Thanks,

swjtx99
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 40627354
Oh yeah, speaking of the criteria, I made the assumption, using this line:
strFindString = objDest.Sheets("Criteria").Cells(1, "B").Value

that the criteria was in cell B1.

Rob.
0
 
LVL 34

Expert Comment

by:Norie
ID: 40627361
You can make some adjusments if you want to keep the criteria in B1.
Sub FilterData()
Dim wbSrc As Workbook
Dim rngCrit As Range
Dim rngDst As Range
Dim rngData As Range

    With ThisWorkbook
        With .Sheets("Criteria")
            .Range("F1:F2").Value = Application.Transpose(.Range("A1:B1").Value)
            Set rngCrit = .Range("F1:F2")
        End With

        Set rngDst = Sheets("Raw Data").Range("A1")
    End With

    Set wbSrc = Workbooks.Open(ThisWorkbook.Path & "\testdata.xls")

    Set rngData = wbSrc.Sheets(1).Range("A1").CurrentRegion

    rngData.AdvancedFilter xlFilterCopy, rngCrit, rngDst

    wbSrc.Close SaveChanges:=False

    ThisWorkbook.Sheets("Criteria").Range("F1:F2").ClearContents

End Sub

Open in new window

0
 

Author Comment

by:swjtx99
ID: 40627367
Hi Flyster,

Thanks for your reply. Your solution works. I did find I had to be on the "Criteria" sheet when it is executed but I can take care of that. I also see that it's only looking at $C$1:$C$2579. This example only has that many rows but a production version could have any number of rows. I think I can change that as well.

The only other problem that I can't seem to fix is that after the macro is executed, the "Raw Data" sheet now has 65K rows making the file size grow from 32kb to 2.7MB and saving the file doesn't reset the last row to the end of the data. I couldn't find any way to get rid of the blank rows except by deleting that sheet. Any idea?

Thanks,

swjtx99
0
 
LVL 22

Accepted Solution

by:
Flyster earned 500 total points
ID: 40627404
OK, instead of copying the whole sheet, I used  lr = ActiveCell.SpecialCells(xlCellTypeLastCell).Row to find the last row with data and copy only that range. I'll be signing off for now as I have to get up in 5 hours to go to work. Hope this works for you.

Sub CopyData()
Dim destrng As Range
Dim lr As Integer
destdata = Range("B1").Value
  Workbooks.Open Filename:= _
    "C:\Enter\Path\Here\testdata.xls"
      lr = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
        Columns("C:C").Select
          Selection.AutoFilter
            ActiveSheet.Range("$C2:$C" & lr).AutoFilter Field:=1, Criteria1:= _
              destdata
                Range("A1:E" & lr).Select
                  Selection.Copy
                    Windows("Destination-Workbook.xls").Activate
                   Sheets("Raw Data").Select
                  Range("A1").Select
                ActiveSheet.Paste
              Columns("A:E").Select
            Selection.Columns.AutoFit
          Application.DisplayAlerts = False
        Windows("testdata.xls").Activate
      ActiveWorkbook.Close savechanges:=False
    Application.DisplayAlerts = True
  Range("A1").Select
End Sub

Open in new window

0
 
LVL 65

Expert Comment

by:RobSampson
ID: 40627411
@swjtx99, did you try my VBS code.  It appeared to work for me just fine.

Rob.
0
 

Author Comment

by:swjtx99
ID: 40629938
Hi Rob,

Thank you for your time and help with the problem. Unfortunately a VBS solution cannot be applied to this specific problem. I was not aware of the possibility of running VBS outside of Excel and now that I know, I can think of a few instances where it would be perfect but unfortunately, not for this one.

Sorry it wouldn't work but thanks again for your valuable expertise and offer of assistance.

Regards,

swjtx99
0
 

Author Closing Comment

by:swjtx99
ID: 40629941
Hi Flyster,

This works very well and with this modification, the last row is now the last row of the dataset copied over.

Thank you for your help.

Regards,

swjtx99
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 40629968
@swjtx99, no problem at all, I understand.  I just like to use VBS instead, since it means you don't have to write macros ;-)

Automating Office outside of the native Office code is great for frequent tasks, and scheduled tasks.

Rob.
0

Featured Post

MS Dynamics Made Instantly Simpler

Make Your Microsoft Dynamics Investment Count  & Drastically Decrease Training Time by Providing Intuitive Step-By-Step WalkThru Tutorials.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The Windows Phone Theme Colours is a tight, powerful, and well balanced palette. This tiny Access application makes it a snap to select and pick a value. And it doubles as an intro to implementing WithEvents, one of Access' hidden gems.
There are times when I have encountered the need to decompress a response from a PHP request. This is how it's done, but you must have control of the request and you can set the Accept-Encoding header.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

635 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question