Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Замена ВПР, подставить Дт Кт - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена ВПР, подставить Дт Кт (Макросы/Sub)
Замена ВПР, подставить Дт Кт
amadeus017 Дата: Понедельник, 22.02.2016, 18:28 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток!

Прошу подкорректировать код, не могу сообразить в чем ошибка.
Есть два файла, "Книга1", которая является справочником данных и файл "П-5_01-2016", источник данных, в который необходимо подставить значения.
В "Книге1", два макроса. Первый, "Ставим код", который открывает файл (в моем случаи "П-5_01-2016") и в графу "AX". проставляет код из таблицы файла "Книга1". Т.е., если в файле "П-5_01-2016" в графе "A", стоят значения, и при равенстве этого значения из таблицы "Книга1" графы "A", ставим значение графы "B" в файл "П-5_01-2016" в графу "AX".
После чего, в графу "AY", вручную проставляю значение услуги

Теперь "Дт" (графа "D") и "Кт" (графа "E") из файла "Книга1", нужно подставить в файл "П-5_01-2016", ссылаясь на графу "AY". Т.е., если в графе "AY" стоит "84", то в графе "BA" должно стоять "6271740000", а в графе "BD" должно стоять "6297740000".

Преобразовал код от пользователя "Udik", и вот что получилось, чему ума не могу дать.
[vba]
Код

Function GetFileName(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath, _
Optional ByVal MyFilter As String = "Книги Excel (*.xls*),") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
If Not IsMissing(InitialPath) Then
On Error Resume Next: ChDrive Left(InitialPath, 1)
ChDir InitialPath ' выбираем стартовую папку
End If
res = Application.GetOpenFilename(MyFilter, , Title, "Открыть") ' вывод диалогового окна
GetFileName = IIf(VarType(res) = vbBoolean, "", res) ' пустая строка при отказе от выбора
End Function

Public Sub ПРFДтКт()
Dim strFN As String, strTWb$
Dim wb2 As Workbook
Dim oDict
Dim str1 As String
Const strLN1 As String = "ПР-5"
Const strLN2 As String = "Page5"

strFN = GetFileName("Выберите файл для обработки", ThisWorkbook.Path) ' запрашиваем имя файла
If strFN = "" Then Exit Sub
strTWb = ActiveWorkbook.FullName
If strFN = strTWb Then Exit Sub
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1

With ActiveWorkbook.Sheets(strLN1)
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
oDict.Item(.Cells(i, 1).Value) = .Cells(i, 2).Value
Next i
End With
Set wb2 = Workbooks.Open(strFN)
With wb2.Sheets(strLN2)
For i = 16 To .Cells(Rows.Count, 51).End(xlUp).Row
str1 = .Cells(i, 51)
.Cells(i, 53).Value = oDict.Item(str1)

Next
End With

wb2.Close
End Sub
[/vba]
К сообщению приложен файл: 9625581.xlsm(27Kb) · -5_01-2016.xlsx(22Kb)


Сообщение отредактировал amadeus017 - Вторник, 23.02.2016, 12:42
 
Ответить
СообщениеДоброго времени суток!

Прошу подкорректировать код, не могу сообразить в чем ошибка.
Есть два файла, "Книга1", которая является справочником данных и файл "П-5_01-2016", источник данных, в который необходимо подставить значения.
В "Книге1", два макроса. Первый, "Ставим код", который открывает файл (в моем случаи "П-5_01-2016") и в графу "AX". проставляет код из таблицы файла "Книга1". Т.е., если в файле "П-5_01-2016" в графе "A", стоят значения, и при равенстве этого значения из таблицы "Книга1" графы "A", ставим значение графы "B" в файл "П-5_01-2016" в графу "AX".
После чего, в графу "AY", вручную проставляю значение услуги

Теперь "Дт" (графа "D") и "Кт" (графа "E") из файла "Книга1", нужно подставить в файл "П-5_01-2016", ссылаясь на графу "AY". Т.е., если в графе "AY" стоит "84", то в графе "BA" должно стоять "6271740000", а в графе "BD" должно стоять "6297740000".

Преобразовал код от пользователя "Udik", и вот что получилось, чему ума не могу дать.
[vba]
Код

Function GetFileName(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath, _
Optional ByVal MyFilter As String = "Книги Excel (*.xls*),") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
If Not IsMissing(InitialPath) Then
On Error Resume Next: ChDrive Left(InitialPath, 1)
ChDir InitialPath ' выбираем стартовую папку
End If
res = Application.GetOpenFilename(MyFilter, , Title, "Открыть") ' вывод диалогового окна
GetFileName = IIf(VarType(res) = vbBoolean, "", res) ' пустая строка при отказе от выбора
End Function

Public Sub ПРFДтКт()
Dim strFN As String, strTWb$
Dim wb2 As Workbook
Dim oDict
Dim str1 As String
Const strLN1 As String = "ПР-5"
Const strLN2 As String = "Page5"

strFN = GetFileName("Выберите файл для обработки", ThisWorkbook.Path) ' запрашиваем имя файла
If strFN = "" Then Exit Sub
strTWb = ActiveWorkbook.FullName
If strFN = strTWb Then Exit Sub
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1

With ActiveWorkbook.Sheets(strLN1)
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
oDict.Item(.Cells(i, 1).Value) = .Cells(i, 2).Value
Next i
End With
Set wb2 = Workbooks.Open(strFN)
With wb2.Sheets(strLN2)
For i = 16 To .Cells(Rows.Count, 51).End(xlUp).Row
str1 = .Cells(i, 51)
.Cells(i, 53).Value = oDict.Item(str1)

Next
End With

wb2.Close
End Sub
[/vba]

Автор - amadeus017
Дата добавления - 22.02.2016 в 18:28
Udik Дата: Понедельник, 22.02.2016, 19:38 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1219
Репутация: 153 ±
Замечаний: 0% ±

Excel 2013
так вы весь блок проверок убрали, может нужное улетело :) (проверять надо)
[vba]
Код

If IsNumeric(.Cells(i, 14)) Then
If .Cells(i, 14) >= 0 Then
.Cells(i, 20).Value = .Cells(i, 14).Value
Else
.Cells(i, 19).Value = Abs(.Cells(i, 14).Value)
End If

End If
[/vba]

потом
т.е. сначала пишем макросом и тут же переправляем ?
==
завтра попробую разобраться
К сообщению приложен файл: 5514951.jpg(13Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com


Сообщение отредактировал Udik - Понедельник, 22.02.2016, 19:50
 
Ответить
Сообщениетак вы весь блок проверок убрали, может нужное улетело :) (проверять надо)
[vba]
Код

If IsNumeric(.Cells(i, 14)) Then
If .Cells(i, 14) >= 0 Then
.Cells(i, 20).Value = .Cells(i, 14).Value
Else
.Cells(i, 19).Value = Abs(.Cells(i, 14).Value)
End If

End If
[/vba]

потом
т.е. сначала пишем макросом и тут же переправляем ?
==
завтра попробую разобраться

Автор - Udik
Дата добавления - 22.02.2016 в 19:38
amadeus017 Дата: Понедельник, 22.02.2016, 23:57 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
т.е. сначала пишем макросом и тут же переправляем ?


Не совсем так, макросом я пользуюсь. Просто понравилось, как макрос умело подставляет "маршрут", в том файле, к которому Вы написали его, после чего применил его к другим таблицам и застопорился на данном примере.
Проверяющий код, это в таблице с "маршрутом", в графе 14, стояли цифры больше и меньше ноля, и в зависимости от значения, проставлялись либо в 19-ю, либо в 20-ю графу. По данной таблице, два макроса.
Первый, подставляет код в графу "50", далее в графу 54, переносит значение из графы 48, а из 49-й графы, в 55.
Второй, хотел запустить, чтобы он по значению услуги (графа 51), в 53-ю графу, ставил значение "Дт", а в 54-ю, значение "Кт" из файла "Книга1".


Сообщение отредактировал amadeus017 - Вторник, 23.02.2016, 00:18
 
Ответить
Сообщение
т.е. сначала пишем макросом и тут же переправляем ?


Не совсем так, макросом я пользуюсь. Просто понравилось, как макрос умело подставляет "маршрут", в том файле, к которому Вы написали его, после чего применил его к другим таблицам и застопорился на данном примере.
Проверяющий код, это в таблице с "маршрутом", в графе 14, стояли цифры больше и меньше ноля, и в зависимости от значения, проставлялись либо в 19-ю, либо в 20-ю графу. По данной таблице, два макроса.
Первый, подставляет код в графу "50", далее в графу 54, переносит значение из графы 48, а из 49-й графы, в 55.
Второй, хотел запустить, чтобы он по значению услуги (графа 51), в 53-ю графу, ставил значение "Дт", а в 54-ю, значение "Кт" из файла "Книга1".

Автор - amadeus017
Дата добавления - 22.02.2016 в 23:57
Udik Дата: Вторник, 23.02.2016, 12:36 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1219
Репутация: 153 ±
Замечаний: 0% ±

Excel 2013
Не совсем так, макросом я пользуюсь..

просто Вы два раза один столбец упомянули в 1 посте, это и озадачило. Ручками, насколько я понимаю, в графу AY (не AX) прописываете значения.


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщение
Не совсем так, макросом я пользуюсь..

просто Вы два раза один столбец упомянули в 1 посте, это и озадачило. Ручками, насколько я понимаю, в графу AY (не AX) прописываете значения.

Автор - Udik
Дата добавления - 23.02.2016 в 12:36
amadeus017 Дата: Вторник, 23.02.2016, 12:43 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Да, Вы правы, это столбик "AY" (51), который заполняется вручную
Можете поправить код?


Сообщение отредактировал amadeus017 - Вторник, 23.02.2016, 15:39
 
Ответить
СообщениеДа, Вы правы, это столбик "AY" (51), который заполняется вручную
Можете поправить код?

Автор - amadeus017
Дата добавления - 23.02.2016 в 12:43
Udik Дата: Вторник, 23.02.2016, 15:56 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1219
Репутация: 153 ±
Замечаний: 0% ±

Excel 2013
Т.е., если в графе "AY" стоит "84"..

Любые другие цифры игнорируем? Странно Вы ТЗ ставите B)

сделал выбор по номеру услуги
[vba]
Код

Public Sub ПРFДтКт()
Dim strTWb As String, str1$
Dim wb2 As Workbook
Dim oDict
Const startRow2 As Long = 2 'начальная строка в файле обработчике

strFN = GetFileName("Выберите файл для обработки", ThisWorkbook.Path) ' запрашиваем имя файла
If strFN = "" Then Exit Sub
If ThisWorkbook.FullName = strTWb Then Exit Sub
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1

With ActiveWorkbook.Sheets(strLN1)
For i = startRow2 To .Cells(Rows.Count, "C").End(xlUp).Row
str1 = .Cells(i, "C").Text
oDict.Item(str1) = i
Next i
End With
Set wb2 = Workbooks.Open(strFN)

With wb2.Sheets(strLN2)
For i = startRow To .Cells(Rows.Count, "AY").End(xlUp).Row
    If (.Cells(i, "AX").Value <> "") Then
        str1 = .Cells(i, "AY")
        If IsNumeric(oDict.Item(str1)) Then
            .Cells(i, "BA") = ThisWorkbook.Worksheets(strLN1).Cells(oDict.Item(str1), "D")
            .Cells(i, "BD") = ThisWorkbook.Worksheets(strLN1).Cells(oDict.Item(str1), "E")
        End If

    End If

Next
End With

wb2.Close
End Sub
[/vba]
К сообщению приложен файл: master.xlsm(28Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщение
Т.е., если в графе "AY" стоит "84"..

Любые другие цифры игнорируем? Странно Вы ТЗ ставите B)

сделал выбор по номеру услуги
[vba]
Код

Public Sub ПРFДтКт()
Dim strTWb As String, str1$
Dim wb2 As Workbook
Dim oDict
Const startRow2 As Long = 2 'начальная строка в файле обработчике

strFN = GetFileName("Выберите файл для обработки", ThisWorkbook.Path) ' запрашиваем имя файла
If strFN = "" Then Exit Sub
If ThisWorkbook.FullName = strTWb Then Exit Sub
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1

With ActiveWorkbook.Sheets(strLN1)
For i = startRow2 To .Cells(Rows.Count, "C").End(xlUp).Row
str1 = .Cells(i, "C").Text
oDict.Item(str1) = i
Next i
End With
Set wb2 = Workbooks.Open(strFN)

With wb2.Sheets(strLN2)
For i = startRow To .Cells(Rows.Count, "AY").End(xlUp).Row
    If (.Cells(i, "AX").Value <> "") Then
        str1 = .Cells(i, "AY")
        If IsNumeric(oDict.Item(str1)) Then
            .Cells(i, "BA") = ThisWorkbook.Worksheets(strLN1).Cells(oDict.Item(str1), "D")
            .Cells(i, "BD") = ThisWorkbook.Worksheets(strLN1).Cells(oDict.Item(str1), "E")
        End If

    End If

Next
End With

wb2.Close
End Sub
[/vba]

Автор - Udik
Дата добавления - 23.02.2016 в 15:56
amadeus017 Дата: Вторник, 23.02.2016, 16:25 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Класс!!!
Все заработало!
Сначала скопировал код, но код стал ругаться на другие строки... Потом скачай файл, оказывается, что Вы переделали предыдущие условия.
УРАААААА!!!!!!!! Буду применять в работу!
Мое почтение Вам!!!

Протестил несколько раз, выявил ошибки, на что следует обращать внимание в работе.
Буду знать, на что обращать внимание ))))


Сообщение отредактировал amadeus017 - Вторник, 23.02.2016, 16:37
 
Ответить
СообщениеКласс!!!
Все заработало!
Сначала скопировал код, но код стал ругаться на другие строки... Потом скачай файл, оказывается, что Вы переделали предыдущие условия.
УРАААААА!!!!!!!! Буду применять в работу!
Мое почтение Вам!!!

Протестил несколько раз, выявил ошибки, на что следует обращать внимание в работе.
Буду знать, на что обращать внимание ))))

Автор - amadeus017
Дата добавления - 23.02.2016 в 16:25
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена ВПР, подставить Дт Кт (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!