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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 208 След.
разделить таблицу на листы
 
Вставьте макрос из сообщения #6 в стандартный модуль и запустите iTown
Вынос в отдельную таблицу названий всех не пустых столбцов
 
Макросом
Код
Sub Tablica()
Dim i As Long
Dim j As Integer
Dim k As Integer
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("I3:N6").ClearContents
  For i = 3 To iLastRow
     k = 0
    For j = 2 To 7
      If Not IsEmpty(Cells(i, j)) Then
        Cells(i, 9 + k) = Cells(2, j)
        k = k + 1
      End If
    Next
  Next
End Sub
Арканы Таро- цифры вместо букв в таблице
 
Цитата
можете ли вы порекомендовать что-то из бумажных книг по экселю
В правом верхнем углу этого сайта есть ССЫЛКИ - много интересного и полезного
Pазбить ячейку, в которой указан диапазон чисел от и до, на несколько строк
 
Цитата
там подсвечена строчка 8
Посмотрите чему при этом равна переменная i и в ячейке Cells(i,"C") какой разделитель, нет ли там пробела?
Pазбить ячейку, в которой указан диапазон чисел от и до, на несколько строк
 
Цитата
но он подсвечивает как ошибку строчку 8.
А в этой строке точно разделитель тире?
Pазбить ячейку, в которой указан диапазон чисел от и до, на несколько строк
 
Попробуйте так
Код
Sub RazdelitStroki()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = iLastRow To 2 Step -1
      If InStr(1, Cells(i, "C"), "-") > 0 Then
        n = Split(Cells(i, "C"), "-")(1)
        Do
          Rows(i + 1).Insert
          Cells(i + 1, "C") = n
          n = n - 1
        Loop While n > Split(Cells(i, "C"), "-")(0) - 1
        Range(Cells(i, "A"), Cells(i + Split(Cells(i, "C"), "-")(1) - Split(Cells(i, "C"), "-")(0) + 1, "A")).FillDown
        Range(Cells(i, "B"), Cells(i + Split(Cells(i, "C"), "-")(1) - Split(Cells(i, "C"), "-")(0) + 1, "B")).FillDown
        Range(Cells(i, "D"), Cells(i + Split(Cells(i, "C"), "-")(1) - Split(Cells(i, "C"), "-")(0) + 1, "D")).FillDown
        Rows(i).Delete
      End If
    Next
End Sub
Pазбить ячейку, в которой указан диапазон чисел от и до, на несколько строк
 
Цитата
В файле 4000 строк примерно
Приложите пример в Excel на 15-20 строк
разделить таблицу на листы
 
Цитата
хотел исправить makros но не получился
Код
Sub iTown()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("MH-2019")
        Columns("E").ClearContents
     'отбор уникальных значений столбца C в столбец E
    Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("E3"), Unique:=True
     'количество уникальных значений городов
        n = Cells(Rows.Count, "E").End(xlUp).Row
    For i = 4 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "E")
        iName = Criterij    'имя нового листа
     'ставим автофильтр по столбцу C
       Sht.Range("A3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AutoFilter 3, Criterij
     'копируем видимые строки в новый лист
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'добавляет новый лист в конец
          .Range("A1:C1").PasteSpecial xlPasteColumnWidths
          .Range("A1:C1").PasteSpecial xlPasteFormats
          .Range("A1:C1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
Application.ScreenUpdating = True
End Sub
Добавить список классификаторов в макрос, есть макрос, удалящий строки по условию
 
Код
Sub uuu1()
 Dim классиф
 Dim i As Long
 Dim n As Long
    классиф = Array("09999/0", "03022/0")
  For n = 0 To UBound(классиф)
    For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
       If InStr(1, Cells(i, 1), классиф(n), vbTextCompare) > 0 Then
      Rows(i).Delete
       End If
    Next
  Next
End Sub
Автозаполнение ячеек в 2 таблицах при выборе значения в другой ячейке
 
В модуль листа Лист1
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A11:E11")) Is Nothing Then
        Application.EnableEvents = False
Dim Fio As String
Dim FoundFio As Range
      Range(Cells(13, Target.Column), Cells(18, Target.Column + 1)).ClearContents
      Fio = Cells(Target.Row, Target.Column)
        Set FoundFio = Rows(1).Find(Fio, , xlValues, xlWhole)
     If Not FoundFio Is Nothing Then
       Range(Cells(3, FoundFio.Column), Cells(8, FoundFio.Column + 1)).Copy Cells(13, Target.Column)
     End If
   End If
    Application.EnableEvents = True
End Sub
Вторую часть задачи попытайтесь решить сами
разделить таблицу на листы
 
Посмотрите https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=90550
макрос разбивает файл на несколько по данным столбца
 
Цитата
еще одно изменение
Определите имя текущей книги перед циклом  
Код
 Set WCur = ThisWorkbook.Worksheets("Лист1")
   CurName = WCur.Parent.Name    'выделяем имя текущей книги без расширения
   CurName = Left(CurName, InStrRev(CurName, ".") - 1) & "_"
А затем добавляем это имя в название новых файлов      
Код
 WbN.SaveAs ThisWorkbook.Path & "\" & CurName & iName & ".xls"
макрос разбивает файл на несколько по данным столбца
 
Код
Sub RaznestiDannye()
Dim i As Long
Dim n As Long
Dim Criterij As String
Dim iName As String
Dim WCur As Worksheet
Dim WbN As Workbook
Dim AutoFilter As AutoFilter
Application.ScreenUpdating = False
   Set WCur = ThisWorkbook.Worksheets("Лист1")
   Columns("R").ClearContents
          'отбор уникальных значений столбца Р в столбец R
    Range("P1:P" & Cells(Rows.Count, "P").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("R1"), Unique:=True
          'количество уникальных значений категорий
    n = Cells(Rows.Count, "R").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям категорий
        Criterij = Cells(i, "R")
        iName = Criterij    'имя новой книги
    'создаем новую книгу с одним листом
      Set WbN = Workbooks.Add(xlWBATWorksheet)
    'ставим автофильтр по столбцу P
          WCur.Range("P1").CurrentRegion.AutoFilter 16, Criterij
    'копируем видимые строки в новую книгу
        WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
        WCur.AutoFilter.Range.AutoFilter
         
        WbN.Sheets("Лист1").Columns("A:P").AutoFit
        WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        WbN.Close SaveChanges:=True
    Next
Application.ScreenUpdating = True
End Sub
Сохранение новых файлов по имени категорий в ту же папку, где и исходный файл
Вытягивание значений до и после определенного слова
 
Код
Sub iКВ()
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B5:C" & iLastRow).ClearContents
 With CreateObject("VBScript.RegExp")
     '.Global = True
     .IgnoreCase = True
     .Pattern = "\,? ?КВ\.?"
   For i = 5 To iLastRow
     If .test(Cells(i, 1)) Then
       Cells(i, 2) = Left(Cells(i, 1), .Execute(Cells(i, 1))(0).FirstIndex)
       Cells(i, 3) = Mid(Cells(i, 1), .Execute(Cells(i, 1))(0).FirstIndex + .Execute(Cells(i, 1))(0).Length + 1)
     Else
       Cells(i, 2) = Cells(i, 1)
     End If
   Next
 End With
End Sub
Разделение в столбцы В и С
[ Закрыто] возможности excel-2003, об использования excel-2003
 
Цитата
как в excel-2003 активировать
Меню Вид - Панели инструментов - поставить галочки у Формы и Элементы управления
Поиск значения по 3м условиям
 
В модуль листа Лист3
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim FoundYear As Range
    If Not Intersect(Target, Range("B17")) Is Nothing Then
        Application.EnableEvents = False
     Set FoundYear = Rows(1).Find(Target, , xlValues, xlWhole)
      If Not FoundYear Is Nothing Then
        Range(Cells(FoundYear.Row + 3, FoundYear.Column), Cells(FoundYear.Row + 12, FoundYear.Column + 12)).Copy _
        Cells(Target.Row + 1, Target.Column + 1)
      End If
    End If
    Application.EnableEvents = True
End Sub
Макрос для подстановки значений через определенное сочетание в пределах одного листа
 
Кросс
http://www.excelworld.ru/forum/10-42748-1
Поиск артикула в ячейке с большим текстовым массивом
 
Sanja, написал, что отображаются только 1024 знака
У меня в ячейке В2 1253 знака и все видны на экране.
Мой макрос находит и подсвечивает 6 соответствий, а макрос от Настя_Nastya ничего не находит.
Я и хочу узнать почему?
Поиск артикула в ячейке с большим текстовым массивом
 
Хотелось бы понять причину такого поведения функции InStr в Excel 2003
Поиск артикула в ячейке с большим текстовым массивом
 
У меня Excel 2003, может он накладывает ограничения
Поиск артикула в ячейке с большим текстовым массивом
 
Цитата
Вы проверяли свой макрос при таком же условии?
Да, проверял. Вставил артикул из А1 несколько раз в разные места ячейки В1. Мой макрос находит все вхождения, а ваш не обнаруживает значения, которые находятся после тысячного (это не точное значение) знакоместа. Попробуйте.
Макрос должен срабатывать на текущем листе
 
Цитата
макрос работает только на странице которая в sheets прописана
А где расположен макрос? В стандартном модуле или в модуле листа?
Поиск артикула в ячейке с большим текстовым массивом
 
Настя_Nastya, проверьте ваш макрос при условии, что искомый артикул будет в конце ячейки В1.
Помню, что было какое-то ограничение для InStr при большой длине предложения.
Поиск артикула в ячейке с большим текстовым массивом
 
Код
Sub iArticul()
Dim i As Long
Dim j As Integer
Dim iLR As Long
Dim re As Object
Dim objMatches As Object
Dim objMatch As Object
  iLR = Cells(Rows.Count, "A").End(xlUp).Row
      Columns("B:B").Font.ColorIndex = 0
  For i = 1 To iLR
      Set re = CreateObject("VBScript.RegExp")
          re.Global = True
          re.IgnoreCase = True
          re.Pattern = Cells(i, "A")
        Set objMatches = re.Execute(Cells(i, "B"))
          If objMatches.Count <> 0 Then
             For j = 0 To objMatches.Count - 1
                Set objMatch = objMatches.Item(j)
                With Cells(i, "B").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
                    .ColorIndex = 3
                End With
             Next
          End If
        Set re = Nothing
    Next
End Sub
Поиск артикула в ячейке с большим текстовым массивом
 
Цитата
есть столбец А с артикулами
А в каждой ячейке столбца А только один артикул?
Что такое в коде := двоеточие и равно
 
Цитата
перечисляю критерии в столбик, то не работает.
Код
Cells.AutoFilter _
Field:=1, _
Criteria1:="*Москва*"
Разделить строку по строчным и прописным
 
Цитата
нужно разделить строку по столбцам
Если предложение в ячейке А1, то запускаете макрос и он делит в В1 и С1
Код
Sub ПрописныеСтрочные()
Dim mo As Object
 With CreateObject("VBScript.RegExp")
   .Global = True
   .MultiLine = True
   .Pattern = "^[А-ЯЁ ]+"
     If .test(Cells(1, 1)) Then
       Set mo = .Execute(Cells(1, 1))
       Cells(1, 2) = mo(0)
       Cells(1, 3) = Mid(Cells(1, 1), mo(0).Length + 1)
    End If
 End With
End Sub
Вытянуть данные из Книги данные соблюдая 2 значения
 
Цитата
конвектор из pdf в Эксель
Я использую конвертер
ABBYY PDF Transformer + , выпуск 12.0.104.225, артикул 1132.27
Позволяет в настройках выбор:
1. Игнорировать текст вне таблицы
2. Сохранять числовые данные в формате «цифры»
3. Сохранять колонтитулы
Разделить строку по строчным и прописным
 
Цитата
найти первый переход с прописной на строчную букву
А прописные всегда в начале предложения?
Получить список уникальных записей VBA
 
Цитата
нужно именно макросом
Код
iLastRow =Cells(Rows.Count, "A").End(xlUp).Row
 Range("A2:A" &iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("C2"),Unique:=True

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 208 След.
Наверх