Sub GetValuesFromMappe2()
Dim src As Workbook, Canceled As Boolean, i As Long, j As Long, curData() As String, msg As Long, newCodes As String
Dim fnd As Range, Updated As Boolean
'OPTIMIZE MACRO SPEED
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'GET THE SOURCE FILE
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the source file"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel files", "*.xls*"
If .Show <> -1 Then
Canceled = True
GoTo ResetSettings
End If
Set src = Workbooks.Open(Filename:=.SelectedItems(1))
End With
'GET THE eX CODES CURRENTLY ON Mappe1
With ThisWorkbook.Worksheets("Ark1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If i = 2 Then
ReDim curData(j)
curData(j) = .Cells(i, "A")
j = j + 1
Else
If IsInArray(.Cells(i, "A"), curData) = False Then
ReDim Preserve curData(j)
curData(j) = .Cells(i, "A")
j = j + 1
End If
End If
Next i
End With
'CHECK CODES TO GET VALUES FOR
CheckCodes:
msg = MsgBox("Would you like to retrieve the data for the following codes? Press Yes if you'd like to proceed, No if you'd like to add more codes, Cancel if " & _
"you'd like to cancel the procedure." & vbCrLf & vbCrLf & "Codes:" & vbCrLf & Join(curData, ", "), vbInformation + vbYesNoCancel, "Check Codes")
If msg = vbYes Then
GoTo Output
ElseIf msg = vbCancel Then
Canceled = True
GoTo ResetSettings
'If new codes are to be added
ElseIf msg = vbNo Then
AddCodes:
'Type in new codes
newCodes = Application.InputBox("Type codes to add (separate each code by a comma with no space).", "Add Codes", Type:=2)
'If InputBox is blank
If newCodes = "False" Then
msg = MsgBox("No codes specified. Would you like to proceed without adding new codes?", vbExclamation + vbYesNoCancel, "Caution")
If msg = vbYes Then
GoTo Output
ElseIf msg = vbNo Then
GoTo AddCodes
ElseIf msg = vbCancel Then
Canceled = True
GoTo ResetSettings
End If
End If
'If InputBox is filled
'Check if the added codes exist on Mappe2
For i = LBound(Split(newCodes, ",")) To UBound(Split(newCodes, ","))
Set fnd = src.Worksheets("Ark1").Range("A:A").Find(Split(newCodes, ",")(i), , xlValues, xlWhole)
If fnd Is Nothing Then
MsgBox "The code " & Split(newCodes, ",")(i) & " was not found on Mappe2.", vbExclamation, "Error"
GoTo AddCodes
Else
Set fnd = Nothing
End If
Next i
'Update the codes to add
For i = LBound(Split(newCodes, ",")) To UBound(Split(newCodes, ","))
If IsInArray(Split(newCodes, ",")(i), curData) = False And Split(newCodes, ",")(i) <> "" Then
ReDim Preserve curData(j)
curData(j) = Split(newCodes, ",")(i)
j = j + 1
End If
Next i
Updated = True
GoTo CheckCodes
End If
Output:
'OUTPUT VALUES
If Updated Then
curData = SortArray(curData)
End If
With ThisWorkbook.Worksheets("Ark1")
For i = LBound(curData) To UBound(curData)
.Cells(i + 2, "A") = curData(i)
Set fnd = src.Worksheets("Ark1").Range("A:A").Find(curData(i), , xlValues, xlWhole)
src.Worksheets("Ark1").Range(Cells(fnd.Row, "B"), Cells(fnd.Row, Columns.Count).End(xlToLeft)).Copy .Cells(i + 2, "B")
Next i
End With
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If Canceled Then
MsgBox "Precedure canceled."
Else
MsgBox "Precedure completed."
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 SortArray(myArray As Variant)
Dim i As Long, j As Long, Temp As Variant
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray)
If CLng(Mid(myArray(i), 2, Len(myArray(i)) - 1)) > CLng(Mid(myArray(j), 2, Len(myArray(i)) - 1)) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
SortArray = myArray
End Function
