Workbook open from specific folder

Hi,

I want to open and save workbook from a specific folder based on H6 cell value or path string.

The workbook will be opened based on column A values Mango, Lichi, Apple one by one then save and closed accordingly.

Can someone please help?

Regards,
Uday

Hi shamim!
Something like below:

Code:

---

Sub fileopen()
Dim pth As String, i As Integer, setting_Sh As Worksheet
Application.ScreenUpdating = False
Set setting_Sh = ThisWorkbook.Sheets("Settings")
With setting_Sh
  pth = .Range("H6").Value
  For i = 1 To .Cells(Rows.Count, 1).End(3).Row
    Workbooks.Open pth & "/" & .Cells(i, 1).Value & ".xlsx"
    'Add processing code here
    ActiveWorkbook.Close True
  Next i
End With
Application.ScreenUpdating = True
End Sub

---

Thanks.:bow:

Hi,

I have updated the file with Data tab.

In Data tab three fruit details are mentioned, I want that Data will be filtered and copy to saved workbook (Mango, Lichi, Apple).

Step 1 - Open saved workbook
Step 2 - Filtered the data
Step 3 - Copy table data from Data tab
Step 4 - Paste onto saved workbook
Step 5 - Close the workbook

Advance thanks
Uday

Please refer to the attachment.

Code:

---

Sub fileopen()
Dim pth As String, i As Integer, setting_Sh As Worksheet, data_Sh As Worksheet
Dim arr, d As Object, Fruit$
Set d = CreateObject("scripting.dictionary")
Set data_Sh = ThisWorkbook.Sheets("Data")
With data_Sh
  arr = .[a1].CurrentRegion
  For i = 2 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
      Set d(arr(i, 1)) = Union(.[a1:b1], .Cells(i, 1).Resize(, 2))
    Else
      Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(, 2))
    End If
  Next i
End With
Application.ScreenUpdating = False
Set setting_Sh = ThisWorkbook.Sheets("Setting")  ' old "Settings" --> new "Setting"
With setting_Sh
  pth = .Range("H6").Value
  For i = 1 To .Cells(Rows.Count, 1).End(3).Row
    Fruit = .Cells(i, 1).Value
    Workbooks.Open pth & "/" & Fruit & ".xlsx"
    d(Fruit).Copy ActiveWorkbook.Sheets(1).[a1]
    ActiveWorkbook.Close True
  Next i
End With
Application.ScreenUpdating = True
End Sub

---

Doing so can save memory.

Code:

---

Sub fileopen()
Dim pth As String, i As Integer, setting_Sh As Worksheet, data_Sh As Worksheet
Dim arr, d As Object, Fruit$
Set d = CreateObject("scripting.dictionary")
Set data_Sh = ThisWorkbook.Sheets("Data")
With data_Sh
  arr = .[a1].CurrentRegion
  For i = 2 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
      d(arr(i, 1)) = "a1:b1," & Cells(i, 1).Resize(, 2).Address(0, 0)
    Else
      d(arr(i, 1)) = d(arr(i, 1)) & "," & Cells(i, 1).Resize(, 2).Address(0, 0)
    End If
  Next i
End With
Application.ScreenUpdating = False
Set setting_Sh = ThisWorkbook.Sheets("Setting")
With setting_Sh
  pth = .Range("H6").Value
  For i = 1 To .Cells(Rows.Count, 1).End(3).Row
    Fruit = .Cells(i, 1).Value
    Workbooks.Open pth & "/" & Fruit & ".xlsx"
    data_Sh.Range(d(Fruit)).Copy ActiveWorkbook.Sheets(1).[a1]
    ActiveWorkbook.Close True
  Next i
End With
Application.ScreenUpdating = True
End Sub

---

Or simply:

Code:

---

Sub M_snb()
  Sheet2.Cells(1).CurrentRegion.Columns(1).AdvancedFilter 2, , Sheet2.Cells(1, 5), 1
  sn = Sheet2.Cells(1, 5).CurrentRegion
  Sheet2.Cells(1, 5).CurrentRegion.Offset(1).ClearContents
 
  For j = 2 To UBound(sn)
      Sheet2.Cells(2, 5) = sn(j, 1)
      With Workbooks.Add
        Sheet2.Cells(1).CurrentRegion.AdvancedFilter 2, Sheet2.Cells(1, 5).CurrentRegion, .Sheets(1).Cells(1)
      End With
    Next
End Sub

---

Thanks for your help. Its really appreciated.

I am trying to implemented the same logic in new attached file.However I am getting error in Stage 2 macro.

**"Fruit Variant is picking up nothing while performing the loop for last time.

I want to include one more condition in the same macro which as follows.

In Data tab if any of the table does (Blue, Green) has new item type which not included previously. i.e., "Banana" the macro should also create new workbook with data onto same mentioned folder.

Regards,
Shamim