Sub file_open()
'fasting settings
Application.Calculation = xlManual
Application.ScreenUpdating = False
Dim wb_base_name As String, rinok_nash_order_column As Integer, ordernum As String, ws_base_name As String, wb_order_name As String, ws_order_name As String, wb As Workbook, ws As Worksheet, model(9999) As String, color(9999) As String, quantity(9999) As Integer, position(9999) As Integer, skin(9999) As Integer, skinrow(9999) As Integer, modwcolor As String, numrow As Integer, cur_sym_pos As Integer, order_column As Integer, filename As String, lrib As Integer
'open file dialog window
ChDir ThisWorkbook.Path & "\"
impfilename = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 2, "Выбрать текстовые или Excel файлы", , False)
If impfilename = "False" Then Exit Sub
wb_base_name = ActiveWorkbook.Name
ws_base_name = ActiveWorkbook.ActiveSheet.Name
Set wb = Application.Workbooks.Open(impfilename)
filename = wb.Name
wb_order_name = wb.Name
For Each ws In wb.Worksheets
ws_order_name = ws.Name
'from managers
'detect columns nums
Dim col_num_nazv, col_num_model, col_num_kol, col_num_last As Integer
For q = 1 To 99
If Right(ws.Cells(1, q), 6) = "Модель" Then col_num_model = q
If Right(ws.Cells(1, q), 10) = "Количество" Then col_num_kol = q
If ws.Cells(1, q) <> "" Then col_num_last = q
Next q
If col_num_nazv <> "" And col_num_model <> "" Then
from_manager = True
For i = 1 To Len(wb.Name)
If IsNumeric(Mid(wb.Name, i, 1)) Then ordernum = ordernum + Mid(wb.Name, i, 1)
If Mid(wb.Name, i, 1) = " " And Len(ordernum) > 0 Then Exit For
Next i
filename = "№" + ordernum + "-"
'reading order
For numrow = 2 To 9999
If ws.Cells(numrow, col_num_model) = "" Then Exit For
If Len(ws.Cells(numrow, col_num_model)) = 1 Then model(numrow - 1) = "0000" + CStr(ws.Cells(numrow, col_num_model))
If Len(ws.Cells(numrow, col_num_model)) = 2 Then model(numrow - 1) = "000" + CStr(ws.Cells(numrow, col_num_model))
If Len(ws.Cells(numrow, col_num_model)) = 3 Then model(numrow - 1) = "00" + CStr(ws.Cells(numrow, col_num_model))
If Len(ws.Cells(numrow, col_num_model)) = 4 Then model(numrow - 1) = "0" + CStr(ws.Cells(numrow, col_num_model))
If Len(ws.Cells(numrow, col_num_model)) = 5 Or Len(ws.Cells(numrow, 2)) = 7 Then model(numrow - 1) = ws.Cells(numrow, col_num_model)
quantity(numrow - 1) = Int(ws.Cells(numrow, col_num_kol))
modwcolor = ws.Cells(numrow, col_num_nazv)
If Left(ws.Cells(1, col_num_nazv), 1) <> "*" And Left(ws.Cells(1, col_num_nazv), 2) <> "ш-" Then skin(numrow - 1) = 0
If Left(ws.Cells(1, col_num_nazv), 1) = "*" Then skin(numrow - 1) = 1
If Left(ws.Cells(1, col_num_nazv), 2) = "ш-" Then skin(numrow - 1) = 2
'selecting color from modwcolor
For cur_sym_pos = Len(modwcolor) - 1 To 1 Step -1
If IsNumeric(Mid(modwcolor, cur_sym_pos, 1)) Or Mid(modwcolor, cur_sym_pos, 1) = "-" Then
color(numrow - 1) = Right(modwcolor, Len(modwcolor) - cur_sym_pos)
Exit For
End If
Next cur_sym_pos
color(numrow - 1) = UCase(Replace(color(numrow - 1), " ", ""))
Next numrow
numrow = numrow - 2
lrib = last_row_in_base(wb_base_name, ws_base_name)
order_column = new_order(wb_base_name, ws_base_name, filename, lrib)
filename = filename + CStr(find_containers(model, color, quantity, position, skin, skinrow, numrow, wb_base_name, ws_base_name, lrib, order_column, wb_order_name, ws_order_name, "manager", rinok_nash_order_column)) + "шт-Резерв-" + InputBox("Введите инициалы менеджера", "Запрос")
numrow = numrow + 1
Workbooks(wb_order_name).Activate
Worksheets(ws_order_name).Activate
ws.Range(Cells(1, col_num_last + 1).Address, Cells(numrow, col_num_last + 1).Address).Copy ws.Cells(1, 30)
ws.Cells(1, 30) = "Не отгружено"
ws.Range(Cells(1, col_num_nazv).Address, Cells(numrow, col_num_nazv).Address).Copy ws.Cells(1, 27)
ws.Range(Cells(1, col_num_kol).Address, Cells(numrow, col_num_kol).Address).Copy ws.Cells(1, 28)
ws.Range(Cells(1, col_num_last).Address, Cells(numrow, col_num_last).Address).Copy ws.Cells(1, 29)
ws.Cells(1, 29) = "Отгружено"
ws.Range("AA1:AA" + CStr(numrow) + ",AB1:AB" + CStr(numrow) + ",AC1:AC" + CStr(numrow) + ",AD1:AD" + CStr(numrow)).Copy
'ws.Range("AA1:AA99999,AB1:AB99999,AC1:AC99999,AD1:AD99999").Copy
Workbooks.Add
ActiveSheet.Paste Destination:=Range("A1")
Application.DisplayAlerts = False
Rows("1:1000").RowHeight = 15
Columns("A:H").AutoFit
'Cells(numrow + 1, 3) = "=СУММ(C2:C" + CStr(numrow) + ")"
Cells(numrow + 1, 4) = Application.WorksheetFunction.Sum(Columns("D:D"))
Cells(numrow + 1, 3) = Application.WorksheetFunction.Sum(Columns("C:C"))
'Cells(numrow + 1, 2) = "=СУММ(B2:B" + CStr(numrow) + ")"
Cells(numrow + 1, 2) = Application.WorksheetFunction.Sum(Columns("B:B"))
ActiveWorkbook.SaveAs _
filename:=".\отправка\" + filename + ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Workbooks(wb_base_name).Activate
Worksheets(ws_base_name).Activate
Cells(1, order_column) = filename
Workbooks(wb_order_name).Activate
Worksheets(ws_order_name).Activate
GoTo labelexit
End If
wb.Close (0)
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Function last_row_in_base(wb_base_name As String, ws_base_name As String) As Integer
Workbooks(wb_base_name).Activate
Worksheets(ws_base_name).Activate
'find last row
For i = 9999 To 1 Step -1
If Cells(i, 16) <> "" Then last_row_in_base = i: Exit For
Next i
End Function
Function new_order(wb_base_name As String, ws_base_name As String, filename As String, lrib As Integer) As Integer
Workbooks(wb_base_name).Activate
Worksheets(ws_base_name).Activate
'find last column
For i = 28 To 9999
If Cells(2, i) <> "" And Cells(3, i) <> "" And Cells(4, i) <> "" And Cells(5, i) <> "" Then new_order = i + 1
Next i
'copy previous columns to new order
Cells(2, new_order) = Format(Date, "dd\/mm")
Cells(2, new_order + 1) = Format(Date, "mm\/dd")
Cells(2, new_order + 2) = Format(Date, "dd\/mm")
Cells(2, new_order + 3) = Format(Date, "mm\/dd")
Cells(1, new_order).Interior.color = 65535
Cells(2, new_order).Interior.color = 65535
Cells(1, new_order + 2).Interior.color = 65535
Cells(2, new_order + 2).Interior.color = 65535
For i = 3 To lrib
Cells(i, new_order).Interior.color = 65535
Cells(i, new_order + 1) = "=RC[-2]-RC[-1]"
Cells(i, new_order + 2).Interior.color = 65535
Cells(i, new_order + 3) = "=RC[-2]-RC[-1]"
Next i
End Function
Function find_containers(model() As String, color() As String, quantity() As Integer, position() As Integer, skin() As Integer, skinrow() As Integer, numrow As Integer, wb_base_name As String, ws_base_name As String, lrib As Integer, order_column As Integer, wb_order_name As String, ws_order_name As String, order_type As String, rinok_nash_order_column As Integer) As Integer
Dim text As String, all_cont_sum As Integer
Workbooks(wb_base_name).Activate
Worksheets(ws_base_name).Activate
Dim containers(99, 2) As Integer
Dim cont_num As Integer, quantity_sum As Integer, balance As Integer, container_found As Boolean, skirow_found As Boolean, skincolumnplus As Integer
For i = 1 To numrow
Erase containers
container_found = False
skinrow_found = False
cont_num = 0
quantity_sum = 0
skincolumnplus = 0
balance = 0
'run across all containers
For baserow = 1 To lrib
'calculate skincolumnplus
If skin(i) = 1 Or (order_type = "manager" And skinrow_found = True And skin(i) <> 2) Then skincolumnplus = 2
'sorting containers massive
Dim tmp As Integer, tmp2 As Integer
For isrt = 1 To cont_num - 1
For jsrt = 1 To cont_num - isrt
If containers(jsrt, 2) > containers(jsrt + 1, 2) Then
tmp = containers(jsrt, 1)
tmp2 = containers(jsrt, 2)
containers(jsrt, 1) = containers(jsrt + 1, 1)
containers(jsrt, 2) = containers(jsrt + 1, 2)
containers(jsrt + 1, 1) = tmp
containers(jsrt + 1, 2) = tmp2
End If
Next jsrt
Next isrt
'if skinrow not found, writing to the order and going to next orderrow
If skin(i) <> 0 And skinrow_found = False Then
Workbooks(wb_order_name).Activate
Worksheets(ws_order_name).Activate
If order_type = "manager" Then
If Cells(1, 6) = "Количество" Then
Cells(i + 1, 8) = Cells(i + 1, 8) + 0
Cells(i + 1, 8).Interior.color = 255
Cells(i + 1, 9) = Cells(i + 1, 9) + quantity(i)
Cells(i + 1, 9).Interior.color = 255
Else
Cells(i + 1, 9) = Cells(i + 1, 9) + 0
Cells(i + 1, 9).Interior.color = 255
Cells(i + 1, 10) = Cells(i + 1, 10) + quantity(i)
Cells(i + 1, 10).Interior.color = 255
End If
Workbooks(wb_base_name).Activate
Worksheets(ws_base_name).Activate
GoTo nexi
End If
'if all container quantity is enought
If quantity_sum >= quantity(i) Then
'search postion in one container
For isrt = 1 To cont_num
If containers(isrt, 2) >= quantity(i) Then
'write to container to order in base
Cells(containers(isrt, 1), order_column + skincolumnplus) = Cells(containers(isrt, 1), order_column + skincolumnplus) + quantity(i)
'write data to skinrow
If (skin(i) = 1 And skinrow_found = True) Or (order_type = "manager" And skinrow_found = True And skin(i) <> 2) Then
Cells(skinrow(i), order_column) = Cells(skinrow(i), order_column) + quantity(i)
Cells(skinrow(i), order_column + 2) = Cells(skinrow(i), order_column + 2) - quantity(i)
End If
container_found = True
Exit For
End If
Next isrt
If quantity_sum = 0 Then
'write zero to base
If containers(0, 1) > 0 Then If Cells(containers(0, 1), order_column + skincolumnplus) = "" Then Cells(containers(0, 1), order_column + skincolumnplus) = 0
If (skin(i) = 1 And skinrow_found = True) Or (order_type = "manager" And skinrow_found = True And skin(i) <> 2) Then
Cells(skinrow(i), order_column) = Cells(skinrow(i), order_column) + 0
Cells(skinrow(i), order_column + 2) = Cells(skinrow(i), order_column + 2) - 0
End If
nexi:
Next i
find_containers = all_cont_sum
End Function
Sub file_import()
file_open
End Sub
|
