Sub Get_1CData()
Const iPath1C$ = "c:\Users\User\Downloads\tst\AndreiSMT\Данные.xlsx" 'путь к файлу с исходными данными
Dim wb1C As Workbook, wbPrice As Workbook, d As Object
Dim arr1C(), arrPrice(), arr(), t$
Dim I&, ii&, iTmp ', iPath1C
Dim iCl As Range, iCell As Range
Application.ScreenUpdating = False
On Error Resume Next
'ChDrive "D"
'ChDir "D:\"
'iPath1C = Application.GetOpenFilename("Файлы Excel (*.xlsx*),*.xlsx*", 1, "Выберите файл с данными", , False)
Set wb1C = Workbooks.Open(iPath1C)
If Not wb1C Is Nothing Then
With wb1C.Worksheets(1)
arr1C = .Range(.Cells(4, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(4, .Columns.Count).End(xlToLeft).Column)).Value
wb1C.Close False
End With
Else
MsgBox "По указанному пути файл с исходными данными отсутствует!", vbCritical + vbOKOnly
Exit Sub
End If
If UBound(arr1C, 1) <> 0 Then
ReDim arr(LBound(arr1C, 1) To UBound(arr1C, 1), 1 To 9)
Else
MsgBox "В исходном файле нет данных или структура файла изменена!", vbCritical + vbOKOnly
Exit Sub
End If
'arrPrice = Worksheets("Price").ListObjects("tblPrice").DataBodyRange.Value
Set wbPrice = Workbooks.Open("c:\Users\User\Downloads\tst\AndreiSMT\Прайс.xlsx")
If Not wbPrice Is Nothing Then
With wbPrice.Worksheets(1)
arrPrice = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(2, .Columns.Count).End(xlToLeft).Column)).Value
wbPrice.Close False
End With
Else
MsgBox "По указанному пути файл Прайс.xlsx отсутствует!", vbCritical + vbOKOnly
Exit Sub
End If
Set d = CreateObject("Scripting.Dictionary"): d.comparemode = 1
For I = 1 To UBound(arrPrice)
t = arrPrice(I, 2) & "|" & arrPrice(I, 4) & "|" & arrPrice(I, 6)
d.Item(t) = arrPrice(I, 1)
Next
For I = LBound(arr1C, 1) To UBound(arr1C, 1)
t = arr1C(I, 1) & "|" & arr1C(I, 3) & "|" & arr1C(I, 5)
If d.exists(t) Then
ii = ii + 1
arr(ii, 1) = d.Item(t)
arr(ii, 3) = arr1C(I, 1)
arr(ii, 2) = arr1C(I, 2)
iTmp = Replace(arr1C(I, 3), ", ", "@@", , 1)
arr(ii, 4) = Split(iTmp, "@@")(0)
arr(ii, 5) = Split(iTmp, "@@")(1)
arr(ii, 6) = arr1C(I, 4)
arr(ii, 8) = arr1C(I, 5)
'With Application.WorksheetFunction
arr(ii, 7) = arr1C(I, 5) / 1.2
arr(ii, 9) = arr1C(I, 4) * arr1C(I, 5)
'End With
End If
Next
With ThisWorkbook.Worksheets("SMT")
Call ResetTable 'очищаем шаблон
.ListObjects("tblShablon").DataBodyRange(1, 1).Resize(UBound(arr, 1), 9) = arr
End With
Application.ScreenUpdating = True
End Sub
|