Import data from another worksheet if criteria is met

bramblepants

New Member
Joined
Jan 24, 2022
Messages
15
Office Version
  1. 365
Platform
  1. Windows
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?
 

Attachments

  • Source.png
    Source.png
    43.8 KB · Views: 13
  • Destination.png
    Destination.png
    23.1 KB · Views: 14

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Try:
VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, arr As Variant
    Dim 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
    arr = Array("Calculation", "Automated Control", "Interface")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    With flder
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsx", 1
        .Title = "Choose an Excel file"
        .AllowMultiSelect = False
        If .Show = True Then
            FileName = .SelectedItems(1)
        End If
    End With
    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").PasteSpecial xlPasteValues
        .Range("A10").CurrentRegion.AutoFilter 4, arr, xlFilterValues
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:E,H:H")).Copy
        desWS2.Range("C6").PasteSpecial xlPasteValues
        .Range("A10").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try:
VBA Code:
Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, arr As Variant
    Dim 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
    arr = Array("Calculation", "Automated Control", "Interface")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    With flder
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsx", 1
        .Title = "Choose an Excel file"
        .AllowMultiSelect = False
        If .Show = True Then
            FileName = .SelectedItems(1)
        End If
    End With
    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").PasteSpecial xlPasteValues
        .Range("A10").CurrentRegion.AutoFilter 4, arr, xlFilterValues
        Intersect(.AutoFilter.Range.Offset(1), .Range("B:E,H:H")).Copy
        desWS2.Range("C6").PasteSpecial xlPasteValues
        .Range("A10").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

That's got it, thanks.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,254
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top