Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
поиск в видимых ячейках\строках, сейчас макрос возвращает данные в скрытых строках, - они не нужны.
 
Ищется часть слова от "контракта":
Код
contract = Cells.Find("*контра*").Offset(0, 1).Select
как сделать поиск только по видимому диапазону листа? спасибо.
Активировать лист рабочей книги из списка, из трёх вариантов
 
А можно сделать сразу список, типо: spisok = Array("Апсны", "Флагман", "разбивки")... и если из списка найден лист- активировать его: .spisok.Select, сейчас использую вот такую конструкцию:
Код
Sub Tеек()
Dim sh As Worksheet

  For Each sh In ThisWorkbook.Worksheets      
        If LCase(sh.Name) Like "апсны" Then
        sh.Select
        End If
        If LCase(sh.Name) Like "флагман" Then
        sh.Select
        End If
        If LCase(sh.Name) Like "разбивки" Then
        sh.Select
        End If 
Next
End Sub
хотелось бы укоротить как-то код... есть мысли какие-то? спасибо. Названия листов будут только в одном экземпляре из списка.
Почему переменные с одинаковыми значениями не видят друг друга?, и выполнение кода пропускает их одинаковые значения, может из-за кавычек, возвращаемых одной из переменных?
 
фрагмент кода(там всё в надстройке работает, нужно очень долго выдергивать для примера, может так будет понятно?):

Код
  ' В столбец "S" нужно вставлять данные на основе словаря "dicDopi".
           If dicDopi.Exists(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = True Then
           If dicDopi.Item(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = "ДОП НУЖЕН" Then

         ' данные для пременной "a" беру отсюдова: 
           a = CStr(tbl.Cells(lngRowIndex - 1, "D").Value)    
                  
            For k = Nachalo To lngKonec Step 1
           ' данные для переменной   kODvD беру здесь:
             KodVd = Val(ActiveSheet.Cells(k, 4).Value)
           ' В ОПРЕДЕЛЕННЫЙ МОМЕНТ УСЛОВИЕ ВЫПОЛНЯЕТСЯ: 9004109100 = 9004109100, 
            If KodVd = a Then
             Cells(k, 19) = Cells(k, 11)
         ' но код не видит , что условие выполнено, а постоянно пререходит на енд иф:
            End If
            Next
переменная KodVd возвращает значение 9004109100: KodVd = 9004109100,см. на фото:
переменная "a" возвращает значение "9004109100":  а = "9004109100", см. на фото:
т.е. после
Код
If KodVd = a Then
должна выполнятся
Код
Cells(k, 19) = Cells(k, 11)
а этого не происходит(
может потому-что
9004109100 <> "9004109100"??
есть идеи какие нить? как исправить?
Изменено: Домкрат - 28 май 2020 15:34:03
Как циклом пройтись по файлам в папке в зависимости от их размера?
 
так вообще возможно делать?
Проблема в том, что когда циклом проходим-обрабатываем файлы, макрос с маленького начинает и в него большой загружает,- получается долго ждать приходиться, а если будет наоборот, то экономим время.
Может как-то обработать предварительно файлы, чтобы сортирнулись по размеру сами?? или что?
Изменено: Домкрат - 18 май 2020 21:12:41
Распознование в тексте латиницы и кириллицы
 
Здравствуйте, как на взгляд специалиста будет сделать лучше, вот фрагмент кода:
Код
'это первоначальный вариант, тут буква Т в  латинской расскладке:

' проверяем наличие буквы Т в инвойсе, если если есть- удоляем её:
       
    If InStr(1, CStr(var), "T", vbTextCompare) > 0 Then
    var = Left(var, Len(var) - 1)

'я добавил игнор ошибки On Error Resume Next и добавил условие Or с русской буквой Т:

    On Error Resume Next
    If InStr(1, CStr(var), "T", vbTextCompare) > 0 Or InStr(1, CStr(var), "Т", vbTextCompare) > 0 Then
    var = Left(var, Len(var) - 1) 




может существуют более лучшие варианты? Если да, то подскажите пожалуйста.
Изменено: Домкрат - 13 май 2020 15:47:21
Почему переменная теряет свое значение?
 
сам код большой, пременная contract строка 18 , когда дело доходит до 92 строки - обнуляется. Что можно с этим сделать, чтобы значение оставалось?
в 92 строке два варианта существует для активации листа по имени... кто хелпнет?
Код
Sub LoopFilesAlko22()
    Dim myFSO As Object, myFolder As Object, myFile As Object
    Dim sh_act As Worksheet, rng_res As Range, res()
    Dim bk As Workbook, Sh As Worksheet
    Dim arr(), r As Long, i As Long, j As Long
    Dim ИМЯКНИГИ As String
    Dim ИМЯЭТОЙКНИГИ As String
    Dim KodV As Variant
    Dim myF As Range
    Dim shFroml As Worksheet
  ИМЯЭТОЙКНИГИ = ActiveWorkbook.name ' ЭТО Я ТЕСТИРУЮ.
  a = Cells.Find("*контра*").Offset(0, 1).Address
  Range(a) = LTrim(RTrim((Range(a))))
 
' ВОТ ЭТА ПЕРЕМЕННАЯ "contract" , КОГДА ДЕЛО ДОХОДИТ ДО 92 строки: If LCase(myFile.name) Like "LT_*" Then
   Set contract = Cells.Find("*контра*").Offset(0, 1) ' объявляем контракт, со здвигом сразу правее на одну ячейку

    ' Откл. монитора.
    Application.DisplayAlerts = False
    
    '3. Создание объекта для работы с папками и файлами.
    Set myFSO = CreateObject(Class:="Scripting.FileSystemObject")
    
    '4. Создание ссылки на папку, в которой находятся инвойсы.
        ' Путь определяется по активному файлу.
    Set myFolder = myFSO.GetFolder(ActiveWorkbook.Path)
    
    '5. Проверка, что нужные файлы не открыты, чтобы не было непредвиденных ситуаций.
        ' Открытым будет только один инвойс, который будет активным.
    For Each myFile In myFolder.Files
        For Each bk In Workbooks
            If bk.FullName <> ActiveWorkbook.FullName Then
                If bk.name = myFile.name Then
                    Application.ScreenUpdating = True
                    MsgBox "Закройте файлы, которые находятся в новой папке." & vbCr & _
                        "Открытым должен быть только один инвойс из новой папки.", vbExclamation
                    Exit Sub
                End If
            End If
        Next bk
    Next myFile
    
'---------------------------------------------------------------------------------------------------------------------
    '6. Сбор информации.
        ' Если в каком-то иновойсе в "G3" не пусто, значит макрос нужно остановить,
        ' т.к. работа уже была сделана.
     ' =========================================================================================
     ' ПОВТОР ПО-НОВОЙ
    '3) Извлечение данных из закрытых инвойсов.
    For Each myFile In myFolder.Files
     ИМЯКНИГИ = ActiveWorkbook.name
     ActiveWorkbook.Save
     
        ' Активный файл пропускаем.
        If myFile.name = ActiveWorkbook.name Then
      
             ' Следующий инвойс.
            
            GoTo metka_NextFile
            
        End If
        
        ' Скрытые файлы пропускаем.
        If (GetAttr(myFile.Path) And vbHidden) <> 0 Then
            GoTo metka_NextFile
        End If
            
        ' Смотрим расширение.
        If Not LCase(myFile.name) Like "*.xls*" Then
            GoTo metka_NextFile
        End If
        ' Смотрим спецификацию.
        If LCase(myFile.name) Like "*specifikacija*" Then
         GoTo metka_NextFile
        End If
        'определяем еслить ли лист в книге, если нет,- следующий файл:
         d = "инвойс"
         On Error Resume Next
         Set wsSheet = Sheets(d)
         If Err.number <> 0 Then
         ActiveWindow.Close savechanges:=False
         GoTo metka_NextFile
         End If
        ' Определяем с каким листом будем работать: отказ: итак буду на етом листе находится!
        'If ActiveSheet.name = "спецификация" Then  только эту строчку коментим,- ниже влияет на всё!
        '========================================================================================
        ' походу из=за этого момента пременная contract теряет свое значание
         If LCase(myFile.name) Like "LT_*" Then
           Set Sh = Workbooks.Open(filename:=myFile.Path, ReadOnly:=False).Worksheets("инвойс")
           Else
         Set Sh = Workbooks.Open(filename:=myFile.Path, ReadOnly:=False).Worksheets("спецификация")
         End If
         '========================================================================================
        
        
'         If ActiveWorkbook.Sheets.count = 1 Then
'         Set Sh = Workbooks.Open(filename:=myFile.Path, ReadOnly:=False).Worksheets("инвойс")
'         If ActiveWorkbook.Sheets.count > 1 Then
'          Set Sh = Workbooks.Open(filename:=myFile.Path, ReadOnly:=False).Worksheets("спецификация")
'         d = "спецификация"
'         On Error Resume Next
'         Set wsSheet = Sheets(d)
'         If Err.number <> 0 Then
'         ActiveWindow.Close savechanges:=False
'         GoTo metka_NextFile
'         End If
           
           'End If
        Sh.Activate
         'определяем еслить ли лист в книге, если нет,- следующий файл:
         d = "инвойс"
         On Error Resume Next
         Set wsSheet = Sheets(d)
         If Err.number <> 0 Then
         ActiveWindow.Close savechanges:=False
         GoTo metka_NextFile
         End If
        ' метка есть- пропускаем файл
        If ActiveSheet.Range("B5").Interior.Color = 16115929 Then
        GoTo metka_NextFile
        End If

        
        ' если метки нету,- , можно с файлом работать!
        If ActiveSheet.Range("B5").Interior.Color <> 16115929 Then
        'MsgBox "это он"
        ' ==========================================================================
        '        '========================================
        'тема контрактов: ПОКА НЕ ЗНАЮ КУДА СТВИТЬ ЭТУ 
        ' удоление лишних пробелов вначале и конце  контракта:
          b = Cells.Find("*контра*").Offset(0, 1).Address
          Range(b) = LTrim(RTrim((Range(b))))
          'определяем номер контракта нового инвойса
         Set contractt = Cells.Find("*контра*").Offset(0, 1) ' объявляем контракт, со здвигом сразу правее на одну ячейку
         ' проверяем контракты:
         If contract <> contractt Then 'если номера контрактов несовпадают, - пропускаем это файл
    

         MsgBox "эти контракты несопасдают:" & contract & contractt

        ' Stop
         ActiveWindow.Close savechanges:=False
         GoTo metka_NextFile
         End If

'
'        '========================================
        
          Windows(ИМЯКНИГИ).Close savechanges:=True
          ' ЗАКРЫВАЕМ ВСЕ ОТКРЫТЫЕ КНИГИ, КРОМЕ АКТИВНОЙ.
          CloseAllWorkbooks_Save ' игоряшин макрос)))))
          
     
        End If

metka_NextFile:
    Next myFile
    Application.ScreenUpdating = True
  ' =========================================================================================
     ' КОНЕЦ ПОВТОРА ПО-НОВОЙ
' удоляем лишние листы в мастер-инвойсе, между активным листом и последним:
' в остальных видах товаров я сам макрос не буду копирувать, только запуск.
DeleteRightSheets
'metka_N:
End Sub
Изменено: Домкрат - 3 май 2020 20:19:20
Удалить из значения знака справа
 
что-то не могу найти похожих тем((, пример в файле прилагаю, может кто подскажет?
в столбце D находятся данные: числа и числа, выглядящие как текст, нужно в столбец AG вернуть эти данные с удаленными 4 знаками справа. МАКРОСОМ НУЖНО, Товарищи.
Изменено: Домкрат - 29 апр 2020 16:16:52
После обработки макросом в числовых значениях разделители точки меняются на запятые и нули пропадают, точки как разделитель у меня стоят специально.
 
Сам макрос выглядит так(файл с примером прилагаю):
Код
Sub Удалить_пробелы1()
 ' есть случаи перевода точек в запятые -- имей введу!
    Dim arr(), spl
    Dim lr As Long, lc As Long, I As Long, ii As Long, j As Long
   
    lr = Cells.Find(what:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).row
    lc = Cells.Find(what:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Column
    arr() = Range("a1").Resize(lr, lc).Value
    For I = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            spl = Split(arr(I, j), Chr(10))
            For ii = 0 To UBound(spl)
                spl(ii) = WorksheetFunction.Trim(spl(ii))
            Next ii
            arr(I, j) = Join(spl, Chr(10))
        Next j
    Next I
    Range("a1").Resize(lr, lc).Value = arr()
 
End Sub
в столбцах N:R находятся числа с разделителями точками, их Sub Удалить_пробелы1 и кромсает.
может кто подскажет как в коде поменять, чтобы точки не трогало оно?? меня хватило на "заплатку", обратная замена запятых на точки:
Код
Sub tочка()
'    '4. Замена запятой на точку.
        ActiveSheet.Columns("N:R").Replace what:=",", Replacement:=".", _
        LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

 
Как скопировать выделенный текст, чтобы через ctrl+V вставить в другую программу.
 
код макроса выглядит в таком виде:
Код
Sub CaSendKeys()
        Range("B10").Select
        Application.SendKeys "{F2}", True ' входим в ячейку
        Application.SendKeys "+{Home}", True   ' выделяем текст в ячейке
        'Application.SendKeys "^(C)", True - пробуем скопировать- не пашет ниразу(((((
      'как теперь скопировать-послать на клавиатуру  выделенныё текст?
        End Sub

Скрытый текст
Изменено: Домкрат - 25 апр 2020 23:06:07
Передача переменной в функцию
 
вот, переменная KodVd возвращает значение из ячейки:
Код
Private Function KodVd(KodVd As Variant)
    Dim KodVd As Variant
    
KodVd = Cells(Columns(4).Find("Код ТН ВЭД").row + 2, Columns(4).Find("Код ТН ВЭД").Column).Value

End Function

правильно ли написана эта фунцкия, и как в дальнейшем, в макросе передать значение из KodVd для использования в коде?
вот, как пример, я принудительно прописал ячейку d23 на переменную KodVd , она передает значение, и всё работает успешно всё:
Код
'определяем первую ячейку с кодом тнвед:
         KodVd = [d23]
'если вставить напрямую:
KodVd = Cells(Columns(4).Find("Код ТН ВЭД").row + 2, Columns(4).Find("Код ТН ВЭД").Column).Value)' выдаст ошибку: overflow
'то выдаст ошибку: overflow

         Select Case KodVd
 ' Алкоголь(вообще с воды начанием):
 Case 2202100000# To 2208909900#

пока сделал вот так, с учётом если будет пусто, с функцией походу прийдётся на потом оставить, а так всё работает именно так, как я себе предствляю исходя из местных условий:
Код
 'определяем первую ячейку с кодом тнвед:
         KodV = [d23]
         If KodV = "" Then
         KodV = [d24]
         End If
        Select Case KodV
 ' Алкоголь(вообще с воды начанием):
 Case 2202100000# To 2208909900#
Изменено: Домкрат - 20 янв 2020 04:07:44
Запускать каждый раз новую процедуру при прохождении цикла
 
Вкратце код выглядит во так:
макрос просматривает файлы в папке, смотрит данные в ячейке, в файлах, если данные верны, то должна запускаться каждый раз разная процедура из списка
Сформировать01
Сформировать02
        Сформировать03
        Сформировать04
        Сформировать05
по кругу:
Код
'3) Извлечение данных из закрытых инвойсов.
    For Each myFile In myFolder.Files
.....
 ' Алкоголь(вообще с воды начанием):
 Case 2202100000# To 2208909900#

         ' работа в инвойсе:
   ЗДЕСЬ НУЖЕН СЧЕТЧИК, ЧТОБЫ ПООЧЕРЕДИ ЗАПУСКАЛ НИЖЕУКАЗАННЫЕ ПРОЦЕДУРЫ.
         Сформировать01
         Сформировать02
         Сформировать03
         Сформировать04
         Сформировать05



' Закрытие инвойса.
        Sh.Parent.Close savechanges:=False
     Case Else
     Sh.Parent.Close savechanges:=False
    GoTo metka_NextFile
End Select
если пройден один цикл,- запускаем процедуру Сформировать01, если два цикла,- запускаем процедуру Сформировать02 и.т.д.
есть идеи какие-нить?  спасибо.
как с помощью цикла выделить вторую пустую ячейку, решение макросом без цикла есть в примере.
 
Хотелось бы найти способ с помощью цикла, начиная от D6 и желательно помимо второй пустой ячейки можно было выделить и третью..
Таблица-список над основной таблицей. Как найти последнюю строку вспомогательной таблицы?
 
В прилагаемом файле пример-описание проблемы. Есть идеи какие-нибудь? Не поделитесь?
Изменено: Домкрат - 10 янв 2020 13:59:59
вечером, после трудного дня, можно же послушать качественную музыку?
 
например, через активные Cantonы, как у меня,- качают достойно, нареканий нет...
Думаю пассивные + усилок брать,- ну такой гемар по сравнению с тем, что имею...
подойдёт-не подойдёт, внешний вид(и колонок и усилка тоже)... долгая и мутная тема, не знаю чем закончится, но пока радуюс, тем что имею)  
Преобразовать текстовые значения ячеек, которые могут интерпретироваться как числа и/или даты
 
чтобы его(форматирование) вернуть, нужно через F2 зайти в ячейку и тогда начинает опять работать. Нашел только такой момент:

Цитата
Application.SendKeys "{F2}", True
эта строка работает только с активной ячейкой, а вот как эту команду , чтобы работало по всему диапазону столбца D неосиливаю. Може кто поможе?
Анализ текста регулярными выражениями (RegExp), поиск по раскладке- русский алфавит не ищет, только принудительно, через |
 
По столбцу Е, в тексте вида Twin F10036 Lon.Skyl.Tin3x 100g ПО 100 ГР. нужно найти цифру(ы) любую, с пробелом или без, содержащую букву Xx в русской или английской раскладке(жирным подсветил), этот случай может быть или не может быть, в коде, в примере, эта строка выглядет так:
Код
objRegExp.Pattern = "(\S)(\d){1,2}( )?([Xx])\b|([Хх])|( )(\d){1,2}( )?([А-Яа-яXx])\b"

я принудительно и русскую раскладку поставил и английскую вот так, через ИЛИ:([Xx])\b|([Хх]), а можно как-то нормально сделать вида: [А-Яа-яA-Za-z]? т.е. упростить хочется код.
поставить пробел между текстом и цифрой с определённой буквой, в конце теста иногда встречаются прикреплённые цифры, их нужно отделить
 
формат текста такой:
Twin F10036 Lon.Skyl.Tin3x - красным покрасил нужный фрагмент для отделения, после цифры идет знак(буква): x, X, с пробелом или без. Есть идеи какие-нить?
Вывести список номеров товаров, где есть примечания, вывести список по отношению к нумерации товаров по столбцу G
 
Здравствуйте, уважаемый GRIM уже написал макрос такого вида, в нём выводиться список с нумерацией строк, а хотелось продолжить тему и сделать список по номерам товаров, в прилагаемом файле я расписал что-к -чему, прошу посодействовать в решении проблемы!
Код
Dim Nachalo As Long, lngKonec As Long
    Dim i As Long, x
    Nachalo = НачалоДанных
    lngKonec = КонецДанных
    On Error Resume Next
    For Each cell In Range(Cells(Nachalo - 1, "F"), Cells(lngKonec, "F"))
        If cell.Comment Is Nothing Then
        Else
            x = x & cell.row & ", "
        End If
    Next
    On Error Resume Next
    x = Left(x, Len(x) - 2)
    If x <> "" Then
    MsgBox "Есть проблемы по письмам, ТОВАРЫ № " & x
    Else
    MsgBox "По письмам замечаний нет!"
    End If
вывести в сообщении список номеров строк с примечаниями, сами примечания ищем по столбцу F
 
Здравствуйте, есть код, в него как-то можно добавить список строк, где могут быть примечания?:
Код
If Not Columns("F").Comment Is Nothing Then
   MsgBox "Ячейка содержит примечание  строки № & И ДАЛЕЕ НОМЕРА СТРОК"
Else
   MsgBox "Ячейка не содержит примечание"
End If

Спасибо.
Изменено: Домкрат - 16 окт 2019 12:20:26
Страницы: 1
Наверх