Open ThisWorkbook & "\" dictionary.txt For Input As #1 ;Открываем файл на чтение
файл находится в этой папке. d:\!_Закрытие\01_2016 Когда я его вставляю в код, то выдает ошибку на эту строчку (сноска на цитату) и выделяет слово "dictionary.txt"
Возможно неправильно вставил? [vba]
Код
Open ThisWorkbook & "d:\!_Закрытие\01_2016" dictionary.txt For Input As #1
[/vba] ;Открываем файл на чтение [moder]Используйте теги для оформления кода (кнопка #)[/moder]
Open ThisWorkbook & "\" dictionary.txt For Input As #1 ;Открываем файл на чтение
файл находится в этой папке. d:\!_Закрытие\01_2016 Когда я его вставляю в код, то выдает ошибку на эту строчку (сноска на цитату) и выделяет слово "dictionary.txt"
Возможно неправильно вставил? [vba]
Код
Open ThisWorkbook & "d:\!_Закрытие\01_2016" dictionary.txt For Input As #1
[/vba] ;Открываем файл на чтение [moder]Используйте теги для оформления кода (кнопка #)[/moder]amadeus017
1) Я неправильно написал (исправил, посмотрите) 2) Вы неправильно вставили. ThisWorkbook.Path — это путь к файлу с макросом, если нужно использовать абсолютный путь (что неудобоваримо, ибо тогда макрос нельзя запускать на другом компе), то ThisWorkbook.Path не нужен: [vba]
Код
Open "d:\!_Закрытие\01_2016\dictionary.txt" For Input As #1
[/vba]
1) Я неправильно написал (исправил, посмотрите) 2) Вы неправильно вставили. ThisWorkbook.Path — это путь к файлу с макросом, если нужно использовать абсолютный путь (что неудобоваримо, ибо тогда макрос нельзя запускать на другом компе), то ThisWorkbook.Path не нужен: [vba]
Код
Open "d:\!_Закрытие\01_2016\dictionary.txt" For Input As #1
То есть Вам нужно создать текстовый файл dictionary.txt, поместить его туда, откуда его возьмёт макрос, скопировать путь к нему из адресной строки Проводника и прописать так: [vba]
Код
Open "<вставить сюда>\dictionary.txt" For Input As #1
[/vba] Формат текстового файла такой:
Город#Г0001 ДругойГород#Д0002
и т. д. Файл для Вашего примера прилагаю.
То есть Вам нужно создать текстовый файл dictionary.txt, поместить его туда, откуда его возьмёт макрос, скопировать путь к нему из адресной строки Проводника и прописать так: [vba]
Код
Open "<вставить сюда>\dictionary.txt" For Input As #1
[/vba] Формат текстового файла такой:
Город#Г0001 ДругойГород#Д0002
и т. д. Файл для Вашего примера прилагаю.StoTisteg
и накосячить в этом файле такоже может . вот для файла-обработчика код
[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 mainSub() Dim strFN As String, strTWb$ Dim wb2 As Workbook Dim oDict Dim str1 As String Const strLN1 As String = "l1" Const strLN2 As String = "basa"
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 = 2 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 = 4 To .Cells(Rows.Count, 15).End(xlUp).Row str1 = .Cells(i, 15) .Cells(i, 18).Value = oDict.Item(str1) 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 Next End With
wb2.Close End Sub
[/vba]
Правда отлов ошибок лень было прописывать , и функцию GetFileName честно потырил strLN2 - имя листа в обрабатываемом файле
и накосячить в этом файле такоже может . вот для файла-обработчика код
[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 mainSub() Dim strFN As String, strTWb$ Dim wb2 As Workbook Dim oDict Dim str1 As String Const strLN1 As String = "l1" Const strLN2 As String = "basa"
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 = 2 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 = 4 To .Cells(Rows.Count, 15).End(xlUp).Row str1 = .Cells(i, 15) .Cells(i, 18).Value = oDict.Item(str1) 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 Next End With
wb2.Close End Sub
[/vba]
Правда отлов ошибок лень было прописывать , и функцию GetFileName честно потырил strLN2 - имя листа в обрабатываемом файлеUdik
То есть Вам нужно создать текстовый файл dictionary.txt, поместить его туда, откуда его возьмёт макрос, скопировать путь к нему из адресной строки Проводника и прописать так:
То есть Вам нужно создать текстовый файл dictionary.txt, поместить его туда, откуда его возьмёт макрос, скопировать путь к нему из адресной строки Проводника и прописать так:
Делаю так как Вы говорите, но все равно ошибкаamadeus017
Нет, больше я прямо в окно не писец даже в простых случаях Прошу прощения, вот рабочее и проверенное: [vba]
Код
Sub CodeForCity()
Dim i As Long
For i = 4 To Cells(Rows.Count, 15).End(xlUp).Row Cells(i, 18).Value = CityCode(Trim(Cells(i, 15).Value)) If Val(Cells(i, 14).Value) < 0 Then Cells(i, 19).Value = Abs(Val(Cells(i, 14).Value)) Else Cells(i, 20).Value = Val(Cells(i, 14).Value) End If Next i
End Sub
Private Function CityCode(City As String) As String
CityCode = "" On Error Resume Next Open ThisWorkbook.Path & "\dictionary.txt" For Input As #1 'Открываем файл на чтение If Err.Number <> 0 Then 'Если у кого-то шаловливые ручки, требуем вернуть всё на место MsgBox prompt:="Положи словарь на место и больше не трогай!" ThisWorkbook.Close End If Do While Not EOF(1) 'Крутимся в цикле до конца файла Line Input #1, CityCode If InStr(1, CityCode, City, vbTextCompare) = 1 And InStr(1, CityCode, "#", vbTextCompare) - 1 = Len(City) Then 'Проверяем, найдена ли нужная строка CityCode = Right(CityCode, Len(CityCode) - InStr(1, CityCode, "#", vbTextCompare)) 'Если да, то вырезаем код и выходим из цикла Exit Do Else CityCode = "" 'Если нет — сбрасываем возвращаемое значение End If Loop Close #1 If CityCode = "" Then MsgBox prompt:="Маршрута на " & City & " в списке нет, пополните список!" 'Проверяем, найден ли маршрут
End Function
[/vba]
Нет, больше я прямо в окно не писец даже в простых случаях Прошу прощения, вот рабочее и проверенное: [vba]
Код
Sub CodeForCity()
Dim i As Long
For i = 4 To Cells(Rows.Count, 15).End(xlUp).Row Cells(i, 18).Value = CityCode(Trim(Cells(i, 15).Value)) If Val(Cells(i, 14).Value) < 0 Then Cells(i, 19).Value = Abs(Val(Cells(i, 14).Value)) Else Cells(i, 20).Value = Val(Cells(i, 14).Value) End If Next i
End Sub
Private Function CityCode(City As String) As String
CityCode = "" On Error Resume Next Open ThisWorkbook.Path & "\dictionary.txt" For Input As #1 'Открываем файл на чтение If Err.Number <> 0 Then 'Если у кого-то шаловливые ручки, требуем вернуть всё на место MsgBox prompt:="Положи словарь на место и больше не трогай!" ThisWorkbook.Close End If Do While Not EOF(1) 'Крутимся в цикле до конца файла Line Input #1, CityCode If InStr(1, CityCode, City, vbTextCompare) = 1 And InStr(1, CityCode, "#", vbTextCompare) - 1 = Len(City) Then 'Проверяем, найдена ли нужная строка CityCode = Right(CityCode, Len(CityCode) - InStr(1, CityCode, "#", vbTextCompare)) 'Если да, то вырезаем код и выходим из цикла Exit Do Else CityCode = "" 'Если нет — сбрасываем возвращаемое значение End If Loop Close #1 If CityCode = "" Then MsgBox prompt:="Маршрута на " & City & " в списке нет, пополните список!" 'Проверяем, найден ли маршрут
Нет, больше я прямо в окно не писец даже в простых случаях shock Прошу прощения, вот рабочее и проверенное:
Работает, но последняя строка, не заполняется. В справочнике этот город есть. Пробовал добавлять строки, думал, что может на количество строк ограничение, ай нет, ограничений в строках не было. Все равно, последняя строка пустая.
Нет, больше я прямо в окно не писец даже в простых случаях shock Прошу прощения, вот рабочее и проверенное:
Работает, но последняя строка, не заполняется. В справочнике этот город есть. Пробовал добавлять строки, думал, что может на количество строк ограничение, ай нет, ограничений в строках не было. Все равно, последняя строка пустая.amadeus017