[ Регистрация · Вход · Новые сообщения · Участники · Правила форума · Поиск · RSS ]
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: irakitin2014  
Заполнение накладных на изготовление деталей
irakitin2014Дата: Суббота, 02.12.2017, 08:41 | Сообщение # 1
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
Вот моя первая тема:
Шеф поставил задачу облегчить заполнение и оформление накладных по отправке деталей на обработку в сторонние организации. Вот что я накропал, сообразуясь со своими пока очень малыми знаниями в VBA.
Алгоритм: В Листе Перечень при помощи комбобокса осуществляется поиск необходимых деталей( продуктов) направляемых на переработку( изготовление)в столбцах отправление или приход ставится количеств деталей на отправку или пришедших. Данное количество автоматически переносится соответственно на листы отправка или приход( формируется накладная), где по нажатии кнопки накладная сохраняется и распечатывается. Количество копий указывается в ячейке К1(зеленого цвета)
ВАЖНО: графа Примечание заполняется ДО заполнения граф отправка или приход
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
Dim Lr As Long
Dim Lr1 As Long
Dim Lr2 As Long
Dim trw As Long
Dim trs As Long
If Target.Count > 1 Then Exit Sub
Lr = Sheets("Перечень").Cells(Rows.Count, 1).End(xlUp).Row
Lr1 = Sheets("Отправка").Cells(Rows.Count, 1).End(xlUp).Row
Lr2 = Sheets("Получение").Cells(Rows.Count, 1).End(xlUp).Row
    If Intersect(Target, Range("E2:F" & Lr)) Is Nothing Then Exit Sub
      trw = Target.Row
      trs = Target.Column
    If trs = 5 Then
        If Range("E" & trw) = "" Then Exit Sub
         Sheets("Перечень").Range("A" & trw & ":E" & trw & "," & "G" & trw).Copy
         Sheets("Отправка").Range("A" & Lr1 + 1).PasteSpecial Paste:=xlPasteValues
         Sheets("Отправка").Range("A" & Lr1 + 1 & ":F" & Lr1 + 1).Borders.LineStyle = xlContinuous
         Sheets("Отправка").Rows(Lr1 + 2).Insert Shift:=xlDown
       Else
         If Range("F" & trw) = "" Then Exit Sub
         Range("A" & trw & ":D" & trw & "," & "F" & trw & ":G" & trw).Copy
         Sheets("Получение").Range("A" & Lr2 + 1).PasteSpecial Paste:=xlPasteValues
         Sheets("Получение").Range("A" & Lr2 + 1 & ":F" & Lr2 + 1).Borders.LineStyle = xlContinuous
         Sheets("Получение").Rows(Lr2 + 2).Insert Shift:=xlDown
    End If
    Application.ScreenUpdating = True
    Application.CutCopyMode = True
    Application.DisplayAlerts = True
End Sub
Прикрепления: 8737745.xlsm (45.8 Kb)



для спасибов ЯД 41001877306852
 
irakitin2014Дата: Суббота, 02.12.2017, 08:43 | Сообщение # 2
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
Все комментарии, критика и наставления на путь истинный приветствуются


для спасибов ЯД 41001877306852
 
dsb75Дата: Суббота, 02.12.2017, 09:36 | Сообщение # 3
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline

Код
If Target.Count > 1 Then Exit Sub

А обновление экрана включить? smile
 
irakitin2014Дата: Суббота, 02.12.2017, 09:42 | Сообщение # 4
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
Дык вроде включено
поясни



для спасибов ЯД 41001877306852
 
dsb75Дата: Суббота, 02.12.2017, 09:42 | Сообщение # 5
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
С отступами беда, конечно. Надо как-то упорядочить их использование.
 
dsb75Дата: Суббота, 02.12.2017, 09:43 | Сообщение # 6
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
Цитата irakitin2014 ()
Дык вроде включено

А после Exit sub тоже включится?
 
irakitin2014Дата: Суббота, 02.12.2017, 09:47 | Сообщение # 7
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
Цитата dsb75 ()
А после Exit sub тоже включится?

опа, спасибо. век живи век учись



для спасибов ЯД 41001877306852
 
dsb75Дата: Суббота, 02.12.2017, 09:48 | Сообщение # 8
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
Но вообще вполне себе хороший код.
 
irakitin2014Дата: Суббота, 02.12.2017, 09:49 | Сообщение # 9
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
то есть после
Код
If Target.Count > 1 Then Exit Sub

надо ставить
Код
Application.DisplayAlerts = True
&



для спасибов ЯД 41001877306852
 
dsb75Дата: Суббота, 02.12.2017, 09:55 | Сообщение # 10
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
Цитата irakitin2014 ()
то есть после ...

Ну не совсем, у вас там 4 выхода из обработчика в теле.
Скорее всего exit sub не использовать
 
dsb75Дата: Суббота, 02.12.2017, 09:57 | Сообщение # 11
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
А комбобокс когда становится не пустым? Я в отправку / приём цифры загнал, а он всё пустой... Он зачем вообще? smile
 
dsb75Дата: Суббота, 02.12.2017, 10:00 | Сообщение # 12
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
А ещё автофильтр стоит нехорошо на табличке - сортировка и количества перемешаются
 
irakitin2014Дата: Суббота, 02.12.2017, 10:00 | Сообщение # 13
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
в комбобоксе надо набрать например 1 или букву д ( к примеру) он для поиска детали. в реале в листе перечень в столбце А больше 5000 строк


для спасибов ЯД 41001877306852
 
irakitin2014Дата: Суббота, 02.12.2017, 10:02 | Сообщение # 14
Генерал-майор
Группа: Модераторы
Сообщений: 312
Репутация: 6
Статус: Offline
автофильтр тоже для удобства поиска: например найти все детали содержащиие цифру 1


для спасибов ЯД 41001877306852
 
dsb75Дата: Суббота, 02.12.2017, 10:05 | Сообщение # 15
Генералиссимус
Группа: Администраторы
Сообщений: 133
Репутация: 2
Статус: Offline
Цитата irakitin2014 ()
автофильтр тоже для удобства

ну так распространите его не все столбцы smile
 
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск: