asked on

Copy Rows from another workbook based on Criteria

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

Norie

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

Flyster

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

RobSampson

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.

swjtx99

ASKER

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

RobSampson

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.

Norie

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

swjtx99

ASKER

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

ASKER CERTIFIED SOLUTION

Flyster

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

RobSampson

@swjtx99, did you try my VBS code. It appeared to work for me just fine.

Rob.

swjtx99

ASKER

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

swjtx99

ASKER

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

RobSampson

@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.