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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 28 След.
Объединение данных в таблице
 
bigfoot, в этой части выгрузки полная каша:
Код
3395ФБГУ Центр Системы Мониторинга Рыболовства и Связи;4 100.000
ФГАУ УПРАВЛЕНИЕ ПО ОРГАНИЗАЦИИ И;
3396ПРОВЕДЕНИЮ СПОРТИВНЫХ МЕРОВПРИЯТИЙ;28 951.000
3397ФГАУ УПРАВЛЕНИЕ ПО ОРГАНИЗАЦИИ И;36 650.000
ФГАУ УПРАВЛЕНИЕ ПО ОРГАНИЗАЦИИ ИПРОВЕДЕНИЮ СПОРТИВНЫХ МЕРОВПРИЯТИЙ;
3398ПРОВЕДЕНИЮ СПОРТИВНЫХ МЕРОВПРИЯТИЙ;57 151.010
ФГАУ УПРАВЛЕНИЕ ПО ОРГАНИЗАЦИИ И;
3399ПРОВЕДЕНИЮ СПОРТИВНЫХ МЕРОВПРИЯТИЙ;40 332.000
3400ФГБОУ ВЫСШЕГО ПРОФЕССИОНАЛЬНОГО;289 815.000
ОБРАЗ.РОССИЙСКИЙ УНИВ-ТДРУЖБЫ НАРОДОВ;
3401РЫБОЛОВСТВА И СВЯЗИФГБУ ЦЕНТР СИСТЕМЫ МОНИТОРИНГА;34 315.000

Думаю, как её победить...

Да, и по кнопке в файле нужно выбрать файл *csv для выгрузки на лист. А приведенный выше макрос именно такие файлы и обрабатывает.

Пока вариант с суммированием по дублям в списке такой:
Скрытый текст
Изменено: Anchoret - 22 Фев 2019 23:52:24
Объединение данных в таблице
 
Код
Sub iRead()
Dim a&, txt$, t$, arr(), b&, c%, t1$, ArrF(), x%
a = 1
With Application.FileDialog(msoFileDialogFilePicker)
  .AllowMultiSelect = False: .Show
  t = .SelectedItems(1)
End With
If Len(t) = 0 Then Exit Sub
Open t For Input As #a
Do
  Line Input #a, txt
  txt = Replace(txt, Chr(34), "")
  If Left(txt, 1) Like "#" Then
    b = b + 1: ReDim Preserve arr(1 To b): c = 1: t1 = ""
    Do While Mid$(txt, c, 1) Like "#"
      t1 = t1 & Mid$(txt, c, 1): c = c + 1
    Loop
    'If Mid$(txt, c, 1) = "w" Then c = c + 1
    txt = t1 & ";" & Mid$(txt, c)
    arr(b) = Split(txt, ";"): t1 = arr(b)(UBound(arr(b))): t = ""
    If InStr(t1, ".") Then t1 = Left$(t1, InStr(t1, ".") - 1)
    For x = 1 To Len(t1)
      If Mid$(t1, x, 1) Like "#" Then t = t & Mid$(t1, x, 1)
    Next
    If Len(t) > 0 Then arr(b)(UBound(arr(b))) = CDbl(t)
  End If
Loop Until EOF(a)
Close #a
ReDim ArrF(1 To b, 1 To UBound(arr(1)) + 1)
For a = 1 To b
  For b = 1 To UBound(ArrF, 2)
    If b - 1 <= UBound(arr(a)) Then ArrF(a, b) = arr(a)(b - 1)
  Next
Next
[A:F].Clear
With [A1].Resize(UBound(ArrF), UBound(ArrF, 2))
 .Value = ArrF: .Borders.LineStyle = 1
End With
[A1].CurrentRegion.EntireColumn.AutoFit
End Sub
Изменено: Anchoret - 22 Фев 2019 21:31:24
Копирование строк из одного документа в другой, Копирование строк из одного документа в другой по выделенным ячейкам
 
Servang,
Код
Sub Poisk()
Dim i&, j&, a&, sh As Worksheet, aa As Range, WB As Workbook, bb As Range, newWB As Workbook
i = 1: Set WB = ThisWorkbook
Set newWB = Workbooks.Add
For Each sh In WB.Worksheets
  a = 0: Set aa = Intersect(sh.UsedRange, sh.Columns(3)).Find("Надякина Р.Ф.", , xlValues, xlPart, xlByColumns, , True)
  If Not aa Is Nothing Then
    Set bb = aa.EntireRow: j = aa.Row: a = a + 1
    Do
      Set aa = Intersect(sh.UsedRange, sh.Columns(3)).FindNext(aa)
      If aa.Row = j Then Exit Do
      Set bb = Union(bb, aa.EntireRow): a = a + 1
    Loop Until aa.Row < j
    bb.Copy newWB.Sheets(1).Cells(i, 1): i = i + a
  End If
Next sh
End Sub
Изменено: Anchoret - 22 Фев 2019 20:09:54
Выделение только видимых ячеек VBA
 
andronus, не знаю куда Вы добавляли код из предложенных вариантов, но свой я тестировал на Вашем же файле-примере. Полагаю остальные участники тоже.

Тестовый файл с тремя вариантами
Изменено: Anchoret - 22 Фев 2019 15:18:20
Out of Memory при добавлении строк в код
 
Либо речь идет не о ручномм вводе кода, а о записи через рекордер всего, что делалось с файлом на протяжении недели.
Копирование строк из одного документа в другой, Копирование строк из одного документа в другой по выделенным ячейкам
 
Собираете строки посредством Union , потом копируете, далее создаете/открываете файл, указываете верхний левый угол для вставки и вставляете скопированное ранее.
После нахождения строки первый раз:
Код
Set RR=sh.Cells(i, 3).EntireRow

При втором и далее:
Код
Set RR=Union(RR,sh.Cells(i, 3).EntireRow)

По окончании цикла проверяете счётчик, если не ноль то:
Код
Set wb=WorkBooks.Open("путь к файлу\имя файла вместе с расширением")
RR.Copy wb.Sheets("название нужного листа").Range("левый верхний угол вставки")
Как правильно использовать CodeName?
 
Цитата
Boris777 написал:
можно ли обойтись без Option Explicit?
Конечно. Я вообще ее никогда не использую. Эта штука полезна только на очень длинных листингах, где задействованы десятки переменных с заковыристыми названиями - на случай опечатки.
Выделение только видимых ячеек VBA
 
andronus, все по последнему вопросу. наслаждайтесь:
Код
Set bb = Range(Cells([A1].Offset(1, 2).Row, [A1].Offset(1, 2).Column), Cells([A1].Offset(1, 2).Row + Range(Cells([A1].Offset(1, 2).Row, [A1].Offset(1, 2).Column), Cells(Cells(Rows.Count, [A1].Offset(1, 2).Column).End(xlUp).Row, [A1].Offset(1, 2).Column)).SpecialCells(xlVisible).Rows.Count - 1, [A1].Offset(1, 2).Column))
t = bb.Address

Но если строка
Код
[A1].Offset(1, 2).Row
будет скрыта (2-я строка) фильтром или руками, то выдаст ошибку.
Можно еще усложнить - от первой не скрытой строки считая от второй строки и до первой скрытой строки по столбцу "C":
Код
Set bb = Range(Cells(Range(Cells([A1].Offset(1, 2).Row, [A1].Offset(1, 2).Column), Cells(Cells(Rows.Count, _
    [A1].Offset(1, 2).Column).End(xlUp).Row, [A1].Offset(1, 2).Column)).SpecialCells(xlVisible).Row, _
    [A1].Offset(1, 2).Column), Cells([A1].Offset(1, 2).Row + Range(Cells([A1].Offset(1, 2).Row, [A1].Offset(1, 2).Column), _
    Cells(Cells(Rows.Count, [A1].Offset(1, 2).Column).End(xlUp).Row, [A1].Offset(1, 2).Column)).SpecialCells(xlVisible).Rows.Count - 1, [A1].Offset(1, 2).Column))
t = bb.Address: bb.Select
Изменено: Anchoret - 21 Фев 2019 20:38:41
Выделение только видимых ячеек VBA
 
andronus,не правильный ответ. Какую задачу Вы пытаетесь решить с помощью этих манипуляций?

Для указанного выше действа (точкой отсчета является активная ячейка):
Код
Sub bbb()
Dim aa As Range, a&, bb As Range
Set aa = Intersect(ActiveCell.EntireRow, Columns(3))
a = aa.Row + 1: Set bb = aa.Offset(, -1)
Do While Cells(a, 3).EntireRow.Hidden = True
  a = a + 1
Loop
Set aa = Union(aa, Cells(a, 3)): aa.Select
bb.Offset(, -1).Formula = "=" & "(" & "sum(" & aa.Address & "))" & "/" & bb.Address
End Sub
Изменено: Anchoret - 21 Фев 2019 19:19:40
Выделение только видимых ячеек VBA
 
andronus, Вы лучше скажите зачем Вам формула через макрос, когда все можно сделать макросом?

Ну и как предположил в прошлой Вашей теме структура файла примера явно отличается от структуры файла, где это все планируется применить.
Вместо попыток почесать левую ногу через голову лучше расскажите (если действительно хотите решить свою задачу) что Вы пытаетесь добиться всеми этими манипуляциями. Лично я пока смысла в них не вижу...
Изменено: Anchoret - 21 Фев 2019 18:48:48
Вставка значения выделения в формулу
 
andronus, у меня на Вашем примере работает. Вывод - пример сильно отличается по структуре от того файла с которым Вы работаете.
Выделение только видимых ячеек VBA
 
andronus, в пошаговом режиме выполните след.код:
Код
Sub aaa()
Set aa = Intersect(Columns("A:C"), ActiveSheet.UsedRange).SpecialCells(xlCellTypeVisible)
For Each bb In Intersect(aa, Columns(1))
t = bb.Address
Next
End Sub
Изменено: Anchoret - 21 Фев 2019 18:28:56
Вставка значения выделения в формулу
 
Код
Sub aaa()
Dim a&
a = 2
Do While Len(Cells(a, 1)) > 0
  Cells(a, 1) = (Cells(a, 3) + Cells(a + 1, 3)) / Cells(a, 2)
  a = a + 2
Loop
End Sub
Вставка значения выделения в формулу
 
Это числители со знаменателями всегда как в файле примере, т.е. напротив ячейки, где будут проводиться вычисления?
И вообще Вы пошли окружным путем... Формулы, выделения...
Изменено: Anchoret - 21 Фев 2019 14:03:56
Выделить дубликаты разным форматированием
 
spy74, макрос, только предварительно нужно удалить УФ из диапазона:
Код
Sub aaa()
Dim aa As Range, AL As Object
Set AL = CreateObject("System.Collections.ArrayList")
For Each aa In Intersect(Columns(1), ActiveSheet.UsedRange)
  If Not AL.contains(aa.Value) Then
    AL.Add aa.Value
  Else: aa.Font.Color = vbRed: aa.Font.Italic = True
  End If
Next
Set AL = Nothing
End Sub
Эксперименты с SortedList
 
В принципе тему можно добавить в местный справочник. Альтернативное название - Описание объекта SortedList с примерами его применения.
Эксперименты с SortedList
 
bedvit, ArrayList позволяет выгрузить все ключи в массив одним махом) SortedList  - нет. Ну или я пока не дорылся до метода, с помощью которого это возможно (CopyTo(), GetKeyList() не работают в VBA).
Эксперименты с SortedList
 
Листая форум наткнулся (в 2016 году, если память не изменяет) на сообщение от Hugo в одной из тем на тему этого объекта. Заинтересовало. Решил провести ряд экспериментов.
Интересовала в первую очередь скорость обработки данных и доступный в VBA инструментарий по работе с SortedList.
----------------
Для тех, кто не в курсе SortedList представляет из себя словарь (ключ, значение) сортирующий сам себя по факту наполнения. В качестве значения может сдержать: строки, числа, массивы, объекты.
---------------
Разочарование №1 - не доступна в VBA выгрузка ключей/итемов в массив, только циклом. Хотя такие методы есть
Разочарование №2 - скорость наполнения (в данном случае и одновременной сортировки) сопоставимо с Dictionary. Но наивно было бы ожидать большую разницу в меньшую сторону.
--------------
Тест-драйв по скорости:
Скрытый текст

Тестер:
Скрытый текст

Результат:
Скрытый текст

На миллионе SortedList завис минут на 10.
-----
В общем для небольших массивов пойдет.
----------------------------------------------------------------
Список доступных методов в VBA:
    Add - добавление пары ключ/значение
    Item - чтение/запись значения по ключу, или перезапись значения ключа
    Count - чтение - кол-во пар в SortedList
    Capacity - чтение/установка количества элементов объекта
Примеры:
Скрытый текст
    Clear - очистка объекта
    Clone - создание копии объекта
    Contains (Key) - проверка наличия определенного ключа в SortedList
    ContainsKey (Key) - проверка наличия определенного ключа в SortedList, т.е. тоже самое что и предыдущее
    ContainsValue (Value) - проверка наличия определенного элемента в SortedList. Не ключа. Полезная штука
    Equals(Object) - сравнение на идентичность двух объектов (например двa SortedList)
    GetByIndex(id) - добыча значения по индексу
    GetKey(id) - взять ключ по его индексу
    IndexOfKey(Key) - получаем индекс по ключу
    IndexOfValue(Value) - индекс по значению
    Remove(Key) - удаление пары ключ/элемент по ключу
    TrimToSize - подгонка пар ключ/элемент под определенное кол-во. В теории полезно только если был установлен завышенный размер массива элементов SortedList
Примеры:
Скрытый текст

---------------------------------------------------------------
Пример сортера на основе SortedList с примером же его использования:
Скрытый текст
Изменено: Anchoret - 20 Фев 2019 17:44:04
удаление листов из книги вне списка/столбца значений макрос
 
Мои пять копеек:
Скрытый текст
Отключить УФ на время печати документа
 
Михаил Лебедев, писалось и тестилось в Excel 2007 . На примере ТС в начале темы все работало.
По последнему файлу ТС также все работает.
Изменено: Anchoret - 19 Фев 2019 12:49:16
Поиск нескольких значений в одной ячейке
 
Если все правильно понял...
Код
Sub aaa()
Dim arr(), dd(), a&, b&, c&, x&
With ActiveSheet
  a = .Cells(.Rows.Count, "A").End(xlUp).Row
  b = Application.CountA(Intersect(.Rows(1), .UsedRange))
  c = Application.CountA(Intersect(.Rows(2), .UsedRange))
  dd = .Range(.Cells(1, 1), .Cells(a, c)).Value
  ReDim arr(1 To b, 1 To c)
  For a = 1 To c
    x = 1
    For c = 1 To b
      If InStr(dd(1, c), dd(2, a)) Then arr(x, a) = dd(1, c): x = x + 1
    Next
  Next
  .Cells(UBound(dd) + 1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub
Данные в табличной форме преобразовать в древовидную, без помощи сводных таблиц
 
Без суммирования:
Код
Sub zzzzzzzz()
Dim a&, b&, c&, d&, x&, arr(), arr1(), dd(), cc(), ss
arr = Sheets(1).[A1:I12].Value
cc = Array(11957550, 15123356, 15652540, 16182238, 16777215)
ReDim arr1(1 To 2, 1 To 1): x = 1: ReDim dd(0 To 4)
arr1(1, 1) = Array(0, vbWhite): a = 3
arr1(2, 1) = Array(arr(1, 5), arr(1, 6), arr(1, 7), arr(1, 8), arr(1, 9))
Do While a <= UBound(arr)
  d = 5
  For b = 1 To 4
    x = x + 1: ReDim Preserve arr1(1 To 2, 1 To x)
    arr1(1, x) = Array(b, cc(b - 1)): arr1(2, x) = Array(arr(a, b), "", "", "", 0)
  Next
  c = b:
  Do
    Do While arr(a, d - 2) = arr(a - 1, d - 2)
      x = x + 1: ReDim Preserve arr1(1 To 2, 1 To x)
      arr1(1, x) = Array(c, cc(c - 1))
      For b = 0 To 4: dd(b) = arr(a - 1, d + b): Next
      arr1(2, x) = dd: a = a + 1
      If a > UBound(arr) Then Exit Do
    Loop
    x = x + 1: ReDim Preserve arr1(1 To 2, 1 To x)
    arr1(1, x) = Array(c, cc(c - 1))
    For b = 0 To 4: dd(b) = arr(a - 1, d + b): Next
    arr1(2, x) = dd
    If a > UBound(arr) Then Exit Do
    If arr(a, 1) <> arr(a - 1, 1) Then a = a + 1: Exit Do
    c = c - 2
    For b = 1 To 2
      x = x + 1: ReDim Preserve arr1(1 To 2, 1 To x)
      arr1(1, x) = Array(c, cc(b)): arr1(2, x) = Array(arr(a, c), "", "", "", 0)
      c = c + 1
    Next
    a = a + 1
  Loop While a <= UBound(arr)
  If a > UBound(arr) Then Exit Do
Loop
Application.ScreenUpdating = False
With Sheets(2)
  .[A:E].Clear
  For a = 1 To UBound(arr1, 2)
    With .Cells(a, 1).Resize(1, UBound(arr1(2, a)) + 1)
      .Value = arr1(2, a): .Interior.Color = arr1(1, a)(1)
    End With
    .Cells(a, 1).IndentLevel = arr1(1, a)(0)
  Next
  .Columns("A:E").AutoFit
End With
Application.ScreenUpdating = True
End Sub
Поиск и подстветка дубликатов в столбце (Не всегда 100% совпадение)
 
Между инициалами всегда только пробелы?
При получении тела HTML страницы текст не соответствует коду страницы в браузере
 
DoEvents?
Отключить УФ на время печати документа
 
edkudin, изменил код выше. Дело было в NumberFormat.
Изменено: Anchoret - 17 Фев 2019 18:10:58
Надпись на кнопке из ячейки таблицы
 
Код
Private Sub CommandButton1_Click()
CommandButton1.Caption = [B2]
End Sub

Private Sub CommandButton2_Click()
CommandButton2.Caption = [B3]
End Sub
Отключить УФ на время печати документа
 
Вроде нет) Есть версии почему так? В смысле почему значения ячеек стали невидимыми...
Изменено: Anchoret - 17 Фев 2019 14:55:57
Отключить УФ на время печати документа
 
Еще вариант, правда в нем после восстановления УФ все значения ячеек становятся невидимыми)
Код
Sub CondFlash()
Dim aa As Range, arr(), a&, b&, c&, dd(), cc()
Set aa = [D4].CurrentRegion
ReDim arr(1 To aa.Rows.Count, 1 To aa.Columns.Count)
For a = 1 To aa.Rows.Count
  For b = 1 To aa.Columns.Count
    If aa(a, b).FormatConditions.Count > 0 Then
      ReDim dd(1 To aa(a, b).FormatConditions.Count): ReDim cc(1 To 12)
      For c = 1 To UBound(dd)
        With aa(a, b).FormatConditions.Item(c)
          cc(1) = .Type: cc(2) = .Operator
          cc(3) = Replace(.Formula1, "=", "")
          cc(4) = Replace(.Formula2, "=", ""): cc(5) = .Priority
          cc(6) = .NumberFormat: cc(7) = .Interior.Color: cc(8) = .Font.Color
          cc(9) = .Font.Bold: cc(10) = .Font.Italic: cc(11) = .StopIfTrue
          cc(12) = .AppliesTo.Address: dd(c) = cc
        End With
      Next
      arr(a, b) = dd
    End If
  Next
Next
aa.FormatConditions.Delete
'-----------
MsgBox "FormatConditions store to Array and Deleted. Ready for Print!"

'-----------
Application.ScreenUpdating = False
For a = 1 To aa.Rows.Count
  For b = 1 To aa.Columns.Count
    If IsArray(arr(a, b)) Then
      For c = 1 To UBound(arr(a, b))
        aa(a, b).FormatConditions.Add Type:=arr(a, b)(c)(1), Operator:=arr(a, b)(c)(2), _
                 Formula1:=arr(a, b)(c)(3), Formula2:=arr(a, b)(c)(4)
        With aa(a, b).FormatConditions(c)
          .Priority = arr(a, b)(c)(5): '.NumberFormat = arr(a, b)(c)(6)
          .Interior.Color = arr(a, b)(c)(7): .Font.Color = arr(a, b)(c)(8)
          .Font.Bold = arr(a, b)(c)(9): .Font.Italic = arr(a, b)(c)(10)
          .StopIfTrue = arr(a, b)(c)(11)
        End With
      Next
    End If
  Next
Next
Application.ScreenUpdating = True
MsgBox "FormatConditions restored!"
End Sub
Изменено: Anchoret - 17 Фев 2019 18:07:02
Cортировка массива VBA
 
ALFA, для 1500-5000 строк особой разницы и не почуствуете)
Вариант с числовым сортером, хотя для него сфера применения массивы от 100к строк (как впрочем и для QuickSort'a):
Скрытый текст
Изменено: Anchoret - 15 Фев 2019 19:59:09
Сведение в ячейку - слов, начинающихся с буквы "А" и заканчивающихся символами "+" или ","
 
С заменой русской "А" на латинскую в начале:
Код
Sub aaa()
Dim Dc As Object, a&, dt$, t1$, t2$, arr()
a = 1: dt = [C7]: dt = Replace(dt, "А", "A")
Set Dc = CreateObject("Scripting.Dictionary")
Do While InStr(a, dt, "A")
  a = InStr(a, dt, "A"): a = a + 1: t1 = vbNullString: t2 = t1
  Do While Mid$(dt, a, 1) Like "#": t1 = t1 & Mid$(dt, a, 1): a = a + 1: Loop
  Do While Mid$(dt, a, 1) <> "," And Mid$(dt, a, 1) <> "+"
    t2 = t2 & Mid$(dt, a, 1): a = a + 1
  Loop
  If Len(t1) > 0 And Len(t2) > 0 Then
    If Not Dc.exists(t2) Then Dc.Add t2, CDbl(t1) Else Dc.Item(t2) = Dc.Item(t2) + CDbl(t1)
  End If
  If a > Len(dt) Then Exit Do
Loop
If Dc.Count > 0 Then
  arr = Dc.keys: t1 = vbNullString
  For a = 0 To UBound(arr)
    t1 = t1 & "A" & Dc.Item(arr(a)) & arr(a) & "+"
  Next
  t1 = Left$(t1, Len(t1) - 1)
End If
[C10] = t1
End Sub
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 28 След.
Наверх