Добрый день! Есть файлик во вложении, там есть форма, где при вводе на первом листе автоматически заполняется строка на другом листе ответственного лица, не могу сделать автоматическую нумерация, просто чтобы автоматом заполнялась форма. Написал строку, назначил ответственного и сразу же проставилась нумерация на первом листе и на другом куда, эта строка скопируется, как это реализовать?
Добрый день! Есть файлик во вложении, там есть форма, где при вводе на первом листе автоматически заполняется строка на другом листе ответственного лица, не могу сделать автоматическую нумерация, просто чтобы автоматом заполнялась форма. Написал строку, назначил ответственного и сразу же проставилась нумерация на первом листе и на другом куда, эта строка скопируется, как это реализовать?flywithme1299
Ну макросом точно можно отслеживать события. Закиньте файл, сохранённый в .xlsx сюда или мне на почту и опишите, в какие листы вставлять и принцип выбора ячейки для заполнения.
Ну макросом точно можно отслеживать события. Закиньте файл, сохранённый в .xlsx сюда или мне на почту и опишите, в какие листы вставлять и принцип выбора ячейки для заполнения.VBAdevelope
Макросы VBA Excel, Word на заказ. Сказать спасибо на Юмани: 410015093172871
VBAdevelope, я выделил желтым, где планируется автонумерация строк. но только тогда, когда заполнится строка или соседняя ячейка в этой строке, автонумерация всегда по порядку, то есть 1.2.3.4.5.6.7, и т.д.
VBAdevelope, я выделил желтым, где планируется автонумерация строк. но только тогда, когда заполнится строка или соседняя ячейка в этой строке, автонумерация всегда по порядку, то есть 1.2.3.4.5.6.7, и т.д.flywithme1299
Это вставьте в свою книгу в модуль "Эта книга" [vba]
Код
Const sCol = "J" Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim oWB As Workbook Dim oSourceSh As Worksheet If Sh.Name <> "Заполнение" Then Exit Sub Set oWB = ActiveWorkbook iCol = Target.Column sAddr = Sh.Cells(1, iCol).Address sAddr = Left(sAddr, InStrRev(sAddr, "$")) If Replace(sAddr, "$", "") = sCol Then iRow = Target.Row sVal = Trim(Target.Value)
iAnsw = MsgBox("Заполнять строку для " & sVal & "?", vbYesNo) If iAnsw = 6 Then If iRow > 1 Then If Sh.Cells(iRow - 1, 1).Value = "¹ ï/ï" Then Sh.Cells(iRow, 1).Value = 1 Else Sh.Cells(iRow, 1).Value = Sh.Cells(iRow - 1, 1).Value + 1 End If End If sVal = fCheckOnValue(oWB, sVal) Set oSourceSh = oWB.Worksheets(sVal) iLast = oSourceSh.Cells(oSourceSh.Rows.Count, 1).End(xlUp).Row If oSourceSh.Range("A" & iLast) = "№ п/п" Then iCurrent = 1 Else iCurrent = iLast + 1 End If iFullFill = iLast + 1 Application.EnableEvents = False 'Nomer oSourceSh.Cells(iFullFill, 1).Value = iCurrent '# data 'Если надо номер + дата, то удалить знак комментирования в конце след строки oSourceSh.Cells(iFullFill, 2).Value = Sh.Cells(iRow, 2) '& " " & Sh.Cells(iRow, 3) 'Naim oSourceSh.Cells(iFullFill, 3).Value = Sh.Cells(iRow, 4) 'Char oSourceSh.Cells(iFullFill, 4).Value = Sh.Cells(iRow, 5) 'Analog oSourceSh.Cells(iFullFill, 5).Value = Sh.Cells(iRow, 6) 'Count oSourceSh.Cells(iFullFill, 6).Value = Sh.Cells(iRow, 7) 'Ed izm oSourceSh.Cells(iFullFill, 7).Value = Sh.Cells(iRow, 8) 'Naim oborud oSourceSh.Cells(iFullFill, 8).Value = Sh.Cells(iRow, 9) 'Prime4 oSourceSh.Cells(iFullFill, 9).Value = Sh.Cells(iRow, 11) Application.EnableEvents = True End If End If End Sub Function fCheckOnValue(ByRef oWB As Workbook, ByVal sVal As String) Dim oSh As Worksheet For Each oSh In oWB.Worksheets If Trim(oSh.Name) = sVal Then fCheckOnValue = oSh.Name Exit Function End If Next oSh End Function
[/vba]
Это вставьте в свою книгу в модуль "Эта книга" [vba]
Код
Const sCol = "J" Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim oWB As Workbook Dim oSourceSh As Worksheet If Sh.Name <> "Заполнение" Then Exit Sub Set oWB = ActiveWorkbook iCol = Target.Column sAddr = Sh.Cells(1, iCol).Address sAddr = Left(sAddr, InStrRev(sAddr, "$")) If Replace(sAddr, "$", "") = sCol Then iRow = Target.Row sVal = Trim(Target.Value)
iAnsw = MsgBox("Заполнять строку для " & sVal & "?", vbYesNo) If iAnsw = 6 Then If iRow > 1 Then If Sh.Cells(iRow - 1, 1).Value = "¹ ï/ï" Then Sh.Cells(iRow, 1).Value = 1 Else Sh.Cells(iRow, 1).Value = Sh.Cells(iRow - 1, 1).Value + 1 End If End If sVal = fCheckOnValue(oWB, sVal) Set oSourceSh = oWB.Worksheets(sVal) iLast = oSourceSh.Cells(oSourceSh.Rows.Count, 1).End(xlUp).Row If oSourceSh.Range("A" & iLast) = "№ п/п" Then iCurrent = 1 Else iCurrent = iLast + 1 End If iFullFill = iLast + 1 Application.EnableEvents = False 'Nomer oSourceSh.Cells(iFullFill, 1).Value = iCurrent '# data 'Если надо номер + дата, то удалить знак комментирования в конце след строки oSourceSh.Cells(iFullFill, 2).Value = Sh.Cells(iRow, 2) '& " " & Sh.Cells(iRow, 3) 'Naim oSourceSh.Cells(iFullFill, 3).Value = Sh.Cells(iRow, 4) 'Char oSourceSh.Cells(iFullFill, 4).Value = Sh.Cells(iRow, 5) 'Analog oSourceSh.Cells(iFullFill, 5).Value = Sh.Cells(iRow, 6) 'Count oSourceSh.Cells(iFullFill, 6).Value = Sh.Cells(iRow, 7) 'Ed izm oSourceSh.Cells(iFullFill, 7).Value = Sh.Cells(iRow, 8) 'Naim oborud oSourceSh.Cells(iFullFill, 8).Value = Sh.Cells(iRow, 9) 'Prime4 oSourceSh.Cells(iFullFill, 9).Value = Sh.Cells(iRow, 11) Application.EnableEvents = True End If End If End Sub Function fCheckOnValue(ByRef oWB As Workbook, ByVal sVal As String) Dim oSh As Worksheet For Each oSh In oWB.Worksheets If Trim(oSh.Name) = sVal Then fCheckOnValue = oSh.Name Exit Function End If Next oSh End Function
flywithme1299, Протестил и поменял. Замените эту процедуру на этот код [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim oWB As Workbook Dim oSourceSh As Worksheet 'On Error GoTo ResumeLine If Sh.Name <> "Заполнение" Then Exit Sub Set oWB = ActiveWorkbook iCol = Target.Column sAddr = Sh.Cells(1, iCol).Address sAddr = Left(sAddr, InStrRev(sAddr, "$")) If Replace(sAddr, "$", "") = sCol Then iRow = Target.Row sVal = Trim(Target.Value)
iAnsw = MsgBox("Заполнять строку для " & sVal & "?", vbYesNo) If iAnsw = 6 Then Application.EnableEvents = False If iRow > 1 Then If Sh.Cells(iRow - 1, 1).Value = "№ п/п" Then Sh.Cells(iRow, 1).Value = 1 Else Sh.Cells(iRow, 1).Value = Sh.Cells(iRow - 1, 1).Value + 1 End If End If sVal = fCheckOnValue(oWB, sVal) Set oSourceSh = oWB.Worksheets(sVal) iLast = oSourceSh.Cells(oSourceSh.Rows.Count, 1).End(xlUp).Row If oSourceSh.Range("A" & iLast) = "№ п/п" Then iCurrent = 1 Else iCurrent = oSourceSh.Range("A" & iLast).Value + 1 End If iFullFill = iLast + 1 'Nomer oSourceSh.Cells(iFullFill, 1).Value = iCurrent '# data 'Если надо номер + дата, то удалить знак комментирования в конце след строки oSourceSh.Cells(iFullFill, 2).Value = Sh.Cells(iRow, 2) '& " " & Sh.Cells(iRow, 3) 'Naim oSourceSh.Cells(iFullFill, 3).Value = Sh.Cells(iRow, 4) 'Char oSourceSh.Cells(iFullFill, 4).Value = Sh.Cells(iRow, 5) 'Analog oSourceSh.Cells(iFullFill, 5).Value = Sh.Cells(iRow, 6) 'Count oSourceSh.Cells(iFullFill, 6).Value = Sh.Cells(iRow, 7) 'Ed izm oSourceSh.Cells(iFullFill, 7).Value = Sh.Cells(iRow, 8) 'Naim oborud oSourceSh.Cells(iFullFill, 8).Value = Sh.Cells(iRow, 9) 'Prime4 oSourceSh.Cells(iFullFill, 9).Value = Sh.Cells(iRow, 11) Application.EnableEvents = True End If End If 'Exit Sub 'ResumeLine: ' If Err Then MsgBox Err.Number & vbCr & Err.Source & vbCr & Err.Description ' Application.EnableEvents = True End Sub
[/vba]
flywithme1299, Протестил и поменял. Замените эту процедуру на этот код [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim oWB As Workbook Dim oSourceSh As Worksheet 'On Error GoTo ResumeLine If Sh.Name <> "Заполнение" Then Exit Sub Set oWB = ActiveWorkbook iCol = Target.Column sAddr = Sh.Cells(1, iCol).Address sAddr = Left(sAddr, InStrRev(sAddr, "$")) If Replace(sAddr, "$", "") = sCol Then iRow = Target.Row sVal = Trim(Target.Value)
iAnsw = MsgBox("Заполнять строку для " & sVal & "?", vbYesNo) If iAnsw = 6 Then Application.EnableEvents = False If iRow > 1 Then If Sh.Cells(iRow - 1, 1).Value = "№ п/п" Then Sh.Cells(iRow, 1).Value = 1 Else Sh.Cells(iRow, 1).Value = Sh.Cells(iRow - 1, 1).Value + 1 End If End If sVal = fCheckOnValue(oWB, sVal) Set oSourceSh = oWB.Worksheets(sVal) iLast = oSourceSh.Cells(oSourceSh.Rows.Count, 1).End(xlUp).Row If oSourceSh.Range("A" & iLast) = "№ п/п" Then iCurrent = 1 Else iCurrent = oSourceSh.Range("A" & iLast).Value + 1 End If iFullFill = iLast + 1 'Nomer oSourceSh.Cells(iFullFill, 1).Value = iCurrent '# data 'Если надо номер + дата, то удалить знак комментирования в конце след строки oSourceSh.Cells(iFullFill, 2).Value = Sh.Cells(iRow, 2) '& " " & Sh.Cells(iRow, 3) 'Naim oSourceSh.Cells(iFullFill, 3).Value = Sh.Cells(iRow, 4) 'Char oSourceSh.Cells(iFullFill, 4).Value = Sh.Cells(iRow, 5) 'Analog oSourceSh.Cells(iFullFill, 5).Value = Sh.Cells(iRow, 6) 'Count oSourceSh.Cells(iFullFill, 6).Value = Sh.Cells(iRow, 7) 'Ed izm oSourceSh.Cells(iFullFill, 7).Value = Sh.Cells(iRow, 8) 'Naim oborud oSourceSh.Cells(iFullFill, 8).Value = Sh.Cells(iRow, 9) 'Prime4 oSourceSh.Cells(iFullFill, 9).Value = Sh.Cells(iRow, 11) Application.EnableEvents = True End If End If 'Exit Sub 'ResumeLine: ' If Err Then MsgBox Err.Number & vbCr & Err.Source & vbCr & Err.Description ' Application.EnableEvents = True End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
