Dim src2 As Workbook
Sub GetValuesFromSpecificCellsInAnotherWorkbook2()
Dim src() As Workbook, desOutput As Worksheet, desCellList As Worksheet, lr As Long, srcAddresses() As String, srcSheets() As String, skip() As Boolean
Dim i As Long, j As Long, k As Long, errSheets() As String, Canceled As Boolean, srcBooks() As String
'OPTIMIZE MACRO SPEED
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'GET THE SOURCE FILE AND DEFINE RELEVANT WORKSHEETS
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the source file"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel files", "*.xls*"
If .Show <> -1 Then
Canceled = True
GoTo ResetSettings
End If
For i = 1 To .SelectedItems.Count
ReDim Preserve src(i - 1)
Set src(i - 1) = Workbooks.Open(Filename:=.SelectedItems(i))
Next i
End With
Set desOutput = ThisWorkbook.Worksheets("POPdata")
Set desCellList = ThisWorkbook.Worksheets("EmilKPI")
'UPDATE COLUMNS IN EmilKPI
Call UpdateEmilKPI2(src)
'GET THE CELL ADDRESSES OF SOURCE DATA
With desCellList
lr = .Range("C:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If lr = 1 Then
MsgBox "There's no reference in " & desCellList.Name, vbExclamation, "Error"
Canceled = True
GoTo ResetSettings
End If
For i = 2 To lr
ReDim Preserve srcAddresses(j)
ReDim Preserve srcSheets(j)
ReDim Preserve srcBooks(j)
ReDim Preserve skip(j)
srcAddresses(j) = .Cells(i, "D") & .Cells(i, "C")
srcSheets(j) = .Cells(i, "E")
If SheetExists2(srcSheets(j), src) = False Then
srcBooks(j) = ""
skip(j) = True
If IsInArray(srcSheets(j), errSheets) = False And srcSheets(j) <> "" Then
ReDim Preserve errSheets(k)
errSheets(k) = srcSheets(j)
k = k + 1
End If
ElseIf .Cells(i, "C") = "" Or .Cells(i, "D") = "" Or .Cells(i, "E") = "" Then
srcBooks(j) = ""
skip(j) = True
Else
srcBooks(j) = src2.Name
skip(j) = False
End If
j = j + 1
Next i
End With
'OUTPUT DATA
With desOutput
j = 2
For i = LBound(srcAddresses) To UBound(srcAddresses)
If skip(i) = False Then
.Cells(j, "B") = Workbooks(srcBooks(i)).Worksheets(srcSheets(i)).Range(srcAddresses(i)).Text
End If
j = j + 1
Next i
.Activate
End With
ResetSettings:
'RESET MACRO OPTIMIZATION SETTINGS
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If Canceled Then
MsgBox "Procedure canceled.", vbInformation, "Canceled"
Else
If IsArrayEmpty(errSheets) Then
MsgBox "Procedure complete.", vbInformation, "Complete"
Else
MsgBox "Procedure complete." & vbCrLf & vbCrLf & "※The following sheets were not found:" & vbCrLf & Join(errSheets, ", "), vbInformation, "Complete"
End If
End If
End Sub
Sub UpdateEmilKPI2(src() As Workbook)
Dim lr As Long, i As Long, noData As Boolean, independent As Boolean, Canceled As Boolean
With ThisWorkbook.Worksheets("EmilKPI")
.Activate
Application.ScreenUpdating = False
lr = .Cells(Rows.Count, "C").End(xlUp).Row
If lr = 1 Then
noData = True
If IsArrayEmpty(src) Then independent = True
GoTo ResetSettings
End If
If IsArrayEmpty(src) Then
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the source file"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel files", "*.xls*"
If .Show <> -1 Then
Canceled = True
GoTo ResetSettings
End If
For i = 1 To .SelectedItems.Count
ReDim Preserve src(i - 1)
Set src(i - 1) = Workbooks.Open(Filename:=.SelectedItems(i))
Next i
End With
End If
For i = 2 To lr
If .Cells(i, "C") <> "" And SheetExists2(.Cells(i, "E"), src) Then
.Cells(i, "D").Value = Split(src2.Worksheets(.Cells(i, "E").Value).Cells(.Cells(i, "C").Value, Columns.Count).End(xlToLeft).Address, "$")(1)
End If
Next i
End With
ResetSettings:
Application.ScreenUpdating = True
If independent And noData Then
MsgBox "There is no data to update.", vbExclamation, "Error"
ElseIf Canceled Then
MsgBox "List updating canceled.", vbInformation, "Canceled"
End If
End Sub
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
Dim element As Variant
On Error GoTo IsInArrayError 'array is empty
For Each element In arr
If element = valToBeFound Then
IsInArray = True
Exit Function
End If
Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function
Function IsArrayEmpty(arr As Variant) As Boolean
On Error Resume Next
IsArrayEmpty = True
IsArrayEmpty = UBound(arr) < LBound(arr)
End Function
Function SheetExists2(WorksheetName As String, ParentWorkbook() As Workbook) As Boolean
Dim i As Long, ws As Worksheet
'If ParentWorkbook Is Nothing Then Set ParentWorkbook = ThisWorkbook
For i = LBound(ParentWorkbook) To UBound(ParentWorkbook)
For Each ws In ParentWorkbook(i).Worksheets
If ws.Name = WorksheetName Then
SheetExists2 = True
Set src2 = ParentWorkbook(i)
Exit Function
End If
Next ws
Next i
End Function
like OTNI
