Прошу подкорректировать код, не могу сообразить в чем ошибка. Есть два файла, "Книга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]
Доброго времени суток!
Прошу подкорректировать код, не могу сообразить в чем ошибка. Есть два файла, "Книга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)
так вы весь блок проверок убрали, может нужное улетело (проверять надо) [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]
потом т.е. сначала пишем макросом и тут же переправляем ? == завтра попробую разобраться
так вы весь блок проверок убрали, может нужное улетело (проверять надо) [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
т.е. сначала пишем макросом и тут же переправляем ?
Не совсем так, макросом я пользуюсь. Просто понравилось, как макрос умело подставляет "маршрут", в том файле, к которому Вы написали его, после чего применил его к другим таблицам и застопорился на данном примере. Проверяющий код, это в таблице с "маршрутом", в графе 14, стояли цифры больше и меньше ноля, и в зависимости от значения, проставлялись либо в 19-ю, либо в 20-ю графу. По данной таблице, два макроса. Первый, подставляет код в графу "50", далее в графу 54, переносит значение из графы 48, а из 49-й графы, в 55. Второй, хотел запустить, чтобы он по значению услуги (графа 51), в 53-ю графу, ставил значение "Дт", а в 54-ю, значение "Кт" из файла "Книга1".
т.е. сначала пишем макросом и тут же переправляем ?
Не совсем так, макросом я пользуюсь. Просто понравилось, как макрос умело подставляет "маршрут", в том файле, к которому Вы написали его, после чего применил его к другим таблицам и застопорился на данном примере. Проверяющий код, это в таблице с "маршрутом", в графе 14, стояли цифры больше и меньше ноля, и в зависимости от значения, проставлялись либо в 19-ю, либо в 20-ю графу. По данной таблице, два макроса. Первый, подставляет код в графу "50", далее в графу 54, переносит значение из графы 48, а из 49-й графы, в 55. Второй, хотел запустить, чтобы он по значению услуги (графа 51), в 53-ю графу, ставил значение "Дт", а в 54-ю, значение "Кт" из файла "Книга1".amadeus017
Сообщение отредактировал amadeus017 - Вторник, 23.02.2016, 00:18
Любые другие цифры игнорируем? Странно Вы ТЗ ставите
сделал выбор по номеру услуги [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
Любые другие цифры игнорируем? Странно Вы ТЗ ставите
сделал выбор по номеру услуги [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
Класс!!! Все заработало! Сначала скопировал код, но код стал ругаться на другие строки... Потом скачай файл, оказывается, что Вы переделали предыдущие условия. УРАААААА!!!!!!!! Буду применять в работу! Мое почтение Вам!!!
Протестил несколько раз, выявил ошибки, на что следует обращать внимание в работе. Буду знать, на что обращать внимание ))))
Класс!!! Все заработало! Сначала скопировал код, но код стал ругаться на другие строки... Потом скачай файл, оказывается, что Вы переделали предыдущие условия. УРАААААА!!!!!!!! Буду применять в работу! Мое почтение Вам!!!
Протестил несколько раз, выявил ошибки, на что следует обращать внимание в работе. Буду знать, на что обращать внимание ))))amadeus017
Сообщение отредактировал amadeus017 - Вторник, 23.02.2016, 16:37