Solved

Copy Rows from another workbook based on Criteria

Posted on 2015-02-23
12
415 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
  • 4
  • 4
  • 2
  • +1
12 Comments
 
LVL 33

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
 

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 33

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
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 

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

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

746 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

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now