Import data from another worksheet if criteria is met

[bramblepants]

Hello, I have searched for this macro but can't quite find something that fits what I need. I would therefore appreciate some help with creating a macro that will:

1. Prompt someone to choose an Excel file
2. Open the Excel file and in the 'IT Dep Summary' sheet, any rows in range D11 to D111 that contain the word "Reports", copy the data from columns B, C, D, E, F, H for the corresponding row
3. Clear and then paste the data from Step 2 into a worksheet named "Reports", starting at cell C6
4. In the same 'IT Dep Summary' sheet, any rows in range D11 to D111 that contain the word "Calculations" or "Automated Controls", copy the data from columns B, C, D, E, H for the corresponding row
5. Clear and then paste the data from Step 4 into a worksheet named "IT Dependencies", starting at cell C6

I have uploaded a couple of screenshots to show what the source data looks like and the template it will be copied into.

Can anyone assist please?

 

[mumps]

Clear and then paste the data

By "clear", do you mean delete the data?

 

[bramblepants]

By "clear", do you mean delete the data?

Hi, yes just clear what is already in the destination cells in the sheet, i.e. don’t delete the entire sheet.

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWS As Worksheet, desWS1 As Worksheet, desWS2 As Worksheet, srcWB As Workbook
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set srcWS = Sheets("IT Dep Summary")
    Set desWS1 = Sheets("Reports")
    desWS1.Range("C5").CurrentRegion.Offset(1).ClearContents
    Set desWS2 = Sheets("IT Dependencies")
    desWS2.Range("C5").CurrentRegion.Offset(1).ClearContents
    With srcWS
        .Range("A10").CurrentRegion.AutoFilter 4, "Report"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:F,H:H")).Copy desWS1.Range("C6")
        .Range("A10").CurrentRegion.AutoFilter 4, Criteria1:="Calculation", Operator:=xlOr, Criteria2:="Automated Control"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:E,H:H")).Copy desWS2.Range("C6")
        .Range("A10").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[bramblepants]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWS As Worksheet, desWS1 As Worksheet, desWS2 As Worksheet, srcWB As Workbook
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set srcWS = Sheets("IT Dep Summary")
    Set desWS1 = Sheets("Reports")
    desWS1.Range("C5").CurrentRegion.Offset(1).ClearContents
    Set desWS2 = Sheets("IT Dependencies")
    desWS2.Range("C5").CurrentRegion.Offset(1).ClearContents
    With srcWS
        .Range("A10").CurrentRegion.AutoFilter 4, "Report"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:F,H:H")).Copy desWS1.Range("C6")
        .Range("A10").CurrentRegion.AutoFilter 4, Criteria1:="Calculation", Operator:=xlOr, Criteria2:="Automated Control"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:E,H:H")).Copy desWS2.Range("C6")
        .Range("A10").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Thanks, I tried this and the following happened:

• I was able to select the source file
• Row 5 (the column headers) in both the Reports and IT Dependencies sheets was cleared, but no data was pasted into either sheets.
• The source file remained open.

There were no error messages.

 

[mumps]

I tested the macro on some dummy file and it worked properly. It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your sheets. Alternately, you could upload a copy of your file (de-sensitized if necessary) to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

 

[bramblepants]

I tested the macro on some dummy file and it worked properly. It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your sheets. Alternately, you could upload a copy of your file (de-sensitized if necessary) to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

I’m a bit restricted with what I can install / access on a company laptop, but I will work something out and upload a dummy file!

 

[bramblepants]

I tested the macro on some dummy file and it worked properly. It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your sheets. Alternately, you could upload a copy of your file (de-sensitized if necessary) to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

I created the two documents referred to in my first post (which I created the screenshots from) and saved them to box.com - Box

The error I am now receiving is 'subscript out of range'

Thanks for the help!

 

[mumps]

Place this macro in the Destination file and run it from there:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWS As Worksheet, desWS1 As Worksheet, desWS2 As Worksheet, srcWB As Workbook
    Set desWS1 = Sheets("Reports")
    desWS1.Range("C5").CurrentRegion.Offset(1).ClearContents
    Set desWS2 = Sheets("IT Dependencies")
    desWS2.Range("C5").CurrentRegion.Offset(1).ClearContents
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set srcWS = Sheets("IT Dep Summary")
    With srcWS
        .Range("A10").CurrentRegion.AutoFilter 4, "Report"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:F,H:H")).Copy desWS1.Range("C6")
        .Range("A10").CurrentRegion.AutoFilter 4, Criteria1:="Calculation", Operator:=xlOr, Criteria2:="Automated Control"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:E,H:H")).Copy desWS2.Range("C6")
        .Range("A10").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[bramblepants]

Place this macro in the Destination file and run it from there:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, FileChosen As Integer, srcWS As Worksheet, desWS1 As Worksheet, desWS2 As Worksheet, srcWB As Workbook
    Set desWS1 = Sheets("Reports")
    desWS1.Range("C5").CurrentRegion.Offset(1).ClearContents
    Set desWS2 = Sheets("IT Dependencies")
    desWS2.Range("C5").CurrentRegion.Offset(1).ClearContents
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a File"
    FileChosen = flder.Show
    FileName = flder.SelectedItems(1)
    Set srcWB = Workbooks.Open(FileName)
    Set srcWS = Sheets("IT Dep Summary")
    With srcWS
        .Range("A10").CurrentRegion.AutoFilter 4, "Report"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:F,H:H")).Copy desWS1.Range("C6")
        .Range("A10").CurrentRegion.AutoFilter 4, Criteria1:="Calculation", Operator:=xlOr, Criteria2:="Automated Control"
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:E,H:H")).Copy desWS2.Range("C6")
        .Range("A10").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

I still get the error 'subscript out of range'. Is this working for you with the same files?