Нужен макрос по поиску и копированию ячеек

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Нужен макрос по поиску и копированию ячеек (Макросы/Sub)

menyazdeznet

Дата: Пятница, 29.06.2018, 13:01 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Всем привет!
Не могу никак написать макрос по заполнению таблицы....

Как это должно работать:
Есть файл
В нем 2 листа.
1й лист - таблица
2й лист - поле для макроса
В таблице 42 колонки, 1я - номер ID, 35 - накладная, 36 - чек, 37 - дата, 38 - поставщик, 39 - возврат, 40 - брак Надо сделать так, чтобы внося на втором листе в определенные ячейки данные, они должны переноситься по нажатию кнопки «добавить» в лист 1, в те строки и в те столбцы, к которым принадлежит ID. Но на листе 1 - этот ID может быть указан несколько раз. Надо внести эту инфу во все места (ячейки), где указан этот ID.
Это было бы удобнее через созданную пользовательскую форму, чтобы листы дополнительные не плодить.

Умоляю помогите

Сообщение отредактировал menyazdeznet - Пятница, 29.06.2018, 13:02

Ответить

StoTisteg

Дата: Пятница, 29.06.2018, 13:13 | Сообщение № 2

Группа: Авторы

Ранг: Старожил

Сообщений: 1161

Репутация: 103 ±

Замечаний: 0% ±

Excel 2010

Цитата menyazdeznet, 29.06.2018 в 13:01, в сообщении № 1 ()

Есть файл

А у нас нет. Печально

Интуитивно понятный код - это когда интуитивно понятно, что это код.

Ответить

menyazdeznet

Дата: Пятница, 29.06.2018, 13:47 | Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Цитата StoTisteg, 29.06.2018 в 13:13, в сообщении № 2 ()

Есть файл
А у нас нет. Печально

Извиняюсь, запамятствовал

Суть в том, чтобы при нажатии на кнопку "добавить" на втором листе - инфа скопировалась в базу и со второго листа поле очистилось.
Может будет проще через пользовательскую форму, но мне уже хоть как надо.
В этом файле попытался отразить хоть как-то действительность в 100.000 позиций.....

Грубо говоря - нужна форма как родная в EXCEL - только с возможностью поиска по таблице

К сообщению приложен файл: SOS.xlsx (17.9 Kb)

Сообщение отредактировал menyazdeznet - Пятница, 29.06.2018, 13:52

Ответить

Kuzmich

Дата: Пятница, 29.06.2018, 15:11 | Сообщение № 4

Группа: Проверенные

Ранг: Ветеран

Сообщений: 711

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

Цитата

чтобы при нажатии на кнопку "добавить" на втором листе - инфа скопировалась в базу и со второго листа поле очистилось.

[vba]

Код

[/vba]

Ответить

menyazdeznet

Дата: Понедельник, 02.07.2018, 08:50 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Kuzmich, ОГРОМНОЕ СПАСИБО!!! А как сделать так, чтобы при заполнении не всех полей на листе "Форма для заполнения", прежние данные не очищались на листе "База"?
А то получается так, что если я "довношу" данные, то другие ячейки в строке - очищаются

Сообщение отредактировал menyazdeznet - Понедельник, 02.07.2018, 08:51

Ответить

Kuzmich

Дата: Понедельник, 02.07.2018, 09:54 | Сообщение № 6

Группа: Проверенные

Ранг: Ветеран

Сообщений: 711

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

Цитата

А как сделать так, чтобы при заполнении не всех полей на листе "Форма для заполнения"

Тогда сообщение о незаполненном поле и выход из программы
[vba]

Код

Sub iVvod()
Dim i As Long
Dim FoundCell As Range
Dim FAdr As String
With Worksheets("БАЗА")
    Set FoundCell = .Columns(1).Find(Range("A3"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      For i = 4 To 22 Step 3
        If Cells(3, i) = "" Then MsgBox "Не заполнено поле: " & Cells(1, i): Exit Sub
      Next
     Do
        .Cells(FoundCell.Row, "AI") = Range("D3")     '№ чека
        .Cells(FoundCell.Row, "AJ") = Range("J3")     'дата чека
        .Cells(FoundCell.Row, "AK") = Range("M3")     'поставщик
       'и т.п.
       Set FoundCell = .Columns(1).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     Else
       MsgBox "На листе 'БАЗА' нет номера: " & Range("A3"): Exit Sub
     End If
End With
   For i = 1 To 22 Step 3
     Range(Cells(3, i), Cells(4, i + 2)).ClearContents
   Next
End Sub

[/vba]

Ответить

menyazdeznet

Дата: Понедельник, 02.07.2018, 10:30 | Сообщение № 7

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Kuzmich,
[vba]

Код

Sub iVvod()
Dim i As Long
Dim FoundCell As Range
Dim FAdr As String
With Worksheets("ÁÀÇÀ")
Set FoundCell = .Columns(1).Find(Range("A3"), , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
Do
If .Cells(FoundCell.Row, "AH") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AH") = Range("D3")
If .Cells(FoundCell.Row, "AI") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AI") = Range("G3")
If .Cells(FoundCell.Row, "AJ") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AJ") = Range("J3")
If .Cells(FoundCell.Row, "AK") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AK") = Range("M3")
If .Cells(FoundCell.Row, "AL") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AL") = Range("P3")
If .Cells(FoundCell.Row, "AM") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AM") = Range("S3")
If .Cells(FoundCell.Row, "AN") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AM") = Range("S3")
If .Cells(FoundCell.Row, "AO") <> 0 Then
.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
Else
.Cells(FoundCell.Row, "AO") = Range("Y3")
Set FoundCell = .Columns(1).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
End With
For i = 1 To 22 Step 3
Range(Cells(3, i), Cells(4, i + 2)).ClearContents
Next
End Sub

[/vba]
А вот тут не могу понять в чем ошибка?

Сообщение отредактировал menyazdeznet - Понедельник, 02.07.2018, 10:52

Ответить

menyazdeznet

Дата: Понедельник, 02.07.2018, 10:32 | Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Писал Skip в поле

Цитата menyazdeznet, 02.07.2018 в 10:30, в сообщении № 7 ()

.Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")

, но тогда он вообще пропускает выполнение макроса

Ответить

menyazdeznet

Дата: Понедельник, 02.07.2018, 10:41 | Сообщение № 9

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

А вот тут не могу понять в чем ошибка?
Я Не про повторяющитеся AH, а про то, что он Loop While говорит, что нет DO он говорит

Ответить

китин

Дата: Понедельник, 02.07.2018, 10:43 | Сообщение № 10

Группа: Модераторы

Ранг: Экселист

Сообщений: 7014

Репутация: 1073 ±

Замечаний: 0% ±

Excel 2007;2010;2016

Цитата menyazdeznet, 02.07.2018 в 10:30, в сообщении № 7 ()

в чем ошибка?

код тэгами не оформлен это главная ошибка

Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852

Ответить

menyazdeznet

Дата: Понедельник, 02.07.2018, 10:53 | Сообщение № 11

Группа: Пользователи

Ранг: Прохожий

Сообщений: 7

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Цитата китин, 02.07.2018 в 10:43, в сообщении № 10 ()

код тэгами не оформлен это главная ошибка

Допустим, КРЯ

Но как починить?
[vba]

Код

Sub iVvod()
Dim i As Long
Dim FoundCell As Range
Dim FAdr As String
With Worksheets("БАЗА")
    Set FoundCell = .Columns(1).Find(Range("A3"), , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
    FAdr = FoundCell.Address
    Do
            If IsEmpty(FoundCell.Row, "AH") = False Then
            .Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
            Else
            .Cells(FoundCell.Row, "AH") = Range("D3")
            If IsEmpty(FoundCell.Row, "AI") = False Then
            .Cells(FoundCell.Row, "AI") = .Cells(FoundCell.Row, "AI")
            Else
            .Cells(FoundCell.Row, "AI") = Range("G3")
            If IsEmpty(FoundCell.Row, "AJ") = False Then
            .Cells(FoundCell.Row, "AJ") = .Cells(FoundCell.Row, "AJ")
            Else
            .Cells(FoundCell.Row, "AJ") = Range("J3")
            If IsEmpty(FoundCell.Row, "AK") = False Then
            .Cells(FoundCell.Row, "AK") = .Cells(FoundCell.Row, "AK")
            Else
            .Cells(FoundCell.Row, "AK") = Range("M3")
            If IsEmpty(FoundCell.Row, "AL") = False Then
            .Cells(FoundCell.Row, "AL") = .Cells(FoundCell.Row, "AL")
            Else
            .Cells(FoundCell.Row, "AL") = Range("P3")
            If IsEmpty(FoundCell.Row, "AM") = False Then
            .Cells(FoundCell.Row, "AM") = .Cells(FoundCell.Row, "AM")
            Else
            .Cells(FoundCell.Row, "AM") = Range("S3")
            If IsEmpty(FoundCell.Row, "AN") = False Then
            .Cells(FoundCell.Row, "AN") = .Cells(FoundCell.Row, "AN")
            Else
            .Cells(FoundCell.Row, "AN") = Range("V3")
            If IsEmpty(FoundCell.Row, "AO") = False Then
            .Cells(FoundCell.Row, "AO") = .Cells(FoundCell.Row, "AO")
            Else
            .Cells(FoundCell.Row, "AO") = Range("Y3")
            End If
    Set FoundCell = .Columns(1).FindNext(FoundCell)
    Loop While FoundCell.Address <> FAdr
    End If
End With
For i = 1 To 22 Step 3
    Range(Cells(3, i), Cells(4, i + 2)).ClearContents
Next
End Sub

[/vba]

Цитата китин, 02.07.2018 в 10:43, в сообщении № 10 ()

код тэгами не оформлен это главная ошибка

Допустим, КРЯ

Но как починить?
[vba]

Код

Sub iVvod()
Dim i As Long
Dim FoundCell As Range
Dim FAdr As String
With Worksheets("БАЗА")
    Set FoundCell = .Columns(1).Find(Range("A3"), , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
    FAdr = FoundCell.Address
    Do
            If IsEmpty(FoundCell.Row, "AH") = False Then
            .Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
            Else
            .Cells(FoundCell.Row, "AH") = Range("D3")
            If IsEmpty(FoundCell.Row, "AI") = False Then
            .Cells(FoundCell.Row, "AI") = .Cells(FoundCell.Row, "AI")
            Else
            .Cells(FoundCell.Row, "AI") = Range("G3")
            If IsEmpty(FoundCell.Row, "AJ") = False Then
            .Cells(FoundCell.Row, "AJ") = .Cells(FoundCell.Row, "AJ")
            Else
            .Cells(FoundCell.Row, "AJ") = Range("J3")
            If IsEmpty(FoundCell.Row, "AK") = False Then
            .Cells(FoundCell.Row, "AK") = .Cells(FoundCell.Row, "AK")
            Else
            .Cells(FoundCell.Row, "AK") = Range("M3")
            If IsEmpty(FoundCell.Row, "AL") = False Then
            .Cells(FoundCell.Row, "AL") = .Cells(FoundCell.Row, "AL")
            Else
            .Cells(FoundCell.Row, "AL") = Range("P3")
            If IsEmpty(FoundCell.Row, "AM") = False Then
            .Cells(FoundCell.Row, "AM") = .Cells(FoundCell.Row, "AM")
            Else
            .Cells(FoundCell.Row, "AM") = Range("S3")
            If IsEmpty(FoundCell.Row, "AN") = False Then
            .Cells(FoundCell.Row, "AN") = .Cells(FoundCell.Row, "AN")
            Else
            .Cells(FoundCell.Row, "AN") = Range("V3")
            If IsEmpty(FoundCell.Row, "AO") = False Then
            .Cells(FoundCell.Row, "AO") = .Cells(FoundCell.Row, "AO")
            Else
            .Cells(FoundCell.Row, "AO") = Range("Y3")
            End If
    Set FoundCell = .Columns(1).FindNext(FoundCell)
    Loop While FoundCell.Address <> FAdr
    End If
End With
For i = 1 To 22 Step 3
    Range(Cells(3, i), Cells(4, i + 2)).ClearContents
Next
End Sub

[/vba]menyazdeznet

Сообщение отредактировал menyazdeznet - Понедельник, 02.07.2018, 12:06

Ответить

Сообщение

Цитата китин, 02.07.2018 в 10:43, в сообщении № 10 ()

код тэгами не оформлен это главная ошибка

Допустим, КРЯ

Но как починить?
[vba]

Код

Sub iVvod()
Dim i As Long
Dim FoundCell As Range
Dim FAdr As String
With Worksheets("БАЗА")
    Set FoundCell = .Columns(1).Find(Range("A3"), , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
    FAdr = FoundCell.Address
    Do
            If IsEmpty(FoundCell.Row, "AH") = False Then
            .Cells(FoundCell.Row, "AH") = .Cells(FoundCell.Row, "AH")
            Else
            .Cells(FoundCell.Row, "AH") = Range("D3")
            If IsEmpty(FoundCell.Row, "AI") = False Then
            .Cells(FoundCell.Row, "AI") = .Cells(FoundCell.Row, "AI")
            Else
            .Cells(FoundCell.Row, "AI") = Range("G3")
            If IsEmpty(FoundCell.Row, "AJ") = False Then
            .Cells(FoundCell.Row, "AJ") = .Cells(FoundCell.Row, "AJ")
            Else
            .Cells(FoundCell.Row, "AJ") = Range("J3")
            If IsEmpty(FoundCell.Row, "AK") = False Then
            .Cells(FoundCell.Row, "AK") = .Cells(FoundCell.Row, "AK")
            Else
            .Cells(FoundCell.Row, "AK") = Range("M3")
            If IsEmpty(FoundCell.Row, "AL") = False Then
            .Cells(FoundCell.Row, "AL") = .Cells(FoundCell.Row, "AL")
            Else
            .Cells(FoundCell.Row, "AL") = Range("P3")
            If IsEmpty(FoundCell.Row, "AM") = False Then
            .Cells(FoundCell.Row, "AM") = .Cells(FoundCell.Row, "AM")
            Else
            .Cells(FoundCell.Row, "AM") = Range("S3")
            If IsEmpty(FoundCell.Row, "AN") = False Then
            .Cells(FoundCell.Row, "AN") = .Cells(FoundCell.Row, "AN")
            Else
            .Cells(FoundCell.Row, "AN") = Range("V3")
            If IsEmpty(FoundCell.Row, "AO") = False Then
            .Cells(FoundCell.Row, "AO") = .Cells(FoundCell.Row, "AO")
            Else
            .Cells(FoundCell.Row, "AO") = Range("Y3")
            End If
    Set FoundCell = .Columns(1).FindNext(FoundCell)
    Loop While FoundCell.Address <> FAdr
    End If
End With
For i = 1 To 22 Step 3
    Range(Cells(3, i), Cells(4, i + 2)).ClearContents
Next
End Sub

[/vba]

Автор - menyazdeznet
Дата добавления - 02.07.2018 в 10:53

Kuzmich

Дата: Понедельник, 02.07.2018, 21:27 | Сообщение № 12

Группа: Проверенные

Ранг: Ветеран

Сообщений: 711

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

Цитата

как сделать так, чтобы при заполнении не всех полей на листе "Форма для заполнения", прежние данные не очищались на листе "База"?

'для № чека
[vba]

Код

            If IsEmpty(Range("D3")) Then
              .Cells(FoundCell.Row, "AI") = .Cells(FoundCell.Row, "AI")
            Else
              .Cells(FoundCell.Row, "AI") = Range("D3")
            End If

[/vba]
Для остальных ячеек аналогично
Или попробуйте так
[vba]

Код

If Not IsEmpty(Range("D3")) Then .Cells(FoundCell.Row, "AI") = Range("D3")

[/vba]

Сообщение отредактировал Kuzmich - Понедельник, 02.07.2018, 21:31

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Нужен макрос по поиску и копированию ячеек (Макросы/Sub)

Страница 1 из 1
1