Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 135 След.
Проблема с кодировкой при чтении txt файла через VBA в Excel
 
Код
ChangeFileCharset Filename,  "Windows-1251", "UTF-8"
txt = CreateObject("scripting.filesystemobject").OpenTextFile(Filename, 1, True).ReadAll

....

End Sub
Function ChangeFileCharset(ByVal filename$, ByVal DestCharset$, _
                           Optional ByVal SourceCharset$) As Boolean
    ' функция перекодировки (смены кодировки) текстового файла
   ' В качестве параметров функция получает путь filename$ к текстовому файлу,
   ' и название кодировки DestCharset$ (в которую будет переведён файл)
   ' Функция возвращает TRUE, если перекодировка прошла успешно
   On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
       .Open
        .LoadFromFile filename$    ' загружаем данные из файла
       FileContent$ = .ReadText   ' считываем текст файла в переменную FileContent$
       .Close
        .Charset = DestCharset$    ' назначаем новую кодировку
       .Open
        .WriteText FileContent$
        .SaveToFile filename$, 2   ' сохраняем файл уже в новой кодировке
       .Close
    End With
    ChangeFileCharset = Err = 0
End Function
Макрос для очистки "Умных таблиц", Макрос для очистки "Умных таблиц"
 
Код
Option Explicit

Const ROWS_COUNT = 3

Sub ClearTablesInActiveWorkbook()
    ClearTablesInWorkbook ActiveWorkbook
End Sub

Sub ClearTablesInWorkbook(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        ClearTablesInWorksheet sh
    Next
End Sub

Sub ClearTablesInWorksheet(sh As Worksheet)
    Dim tb As ListObject
    For Each tb In sh.ListObjects
        ClearTable tb
    Next
End Sub

Sub ClearTable(tb As ListObject)
    Dim rn As Range
    On Error Resume Next
    Set rn = tb.Range
    On Error GoTo 0
    If Not rn Is Nothing Then
        If rn.Rows.Count > ROWS_COUNT Then
            rn.Cells(ROWS_COUNT + 1, 1).Resize(rn.Rows.Count - ROWS_COUNT, rn.Columns.Count).Clear
            tb.Resize rn.Cells(1, 1).Resize(ROWS_COUNT, rn.Columns.Count)
        End If
    End If
End Sub
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Цитата
написал:
МатросНаЗебре , на огрызке нет словаря!
Была у меня такая гипотеза, теперь она превратилась в аксиому )
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Код
'Без словаря.
Option Explicit
Const MAN_COLUMN = 21
Dim rnMain As Range
Dim arrMain As Variant
Dim arrOneMan As Variant

Sub MakeManagersFiles()
    'Range("A2:H271").Select
    Set rnMain = GetMainRange()
    JobMainRange
End Sub

Private Function GetMainRange() As Range
    Dim rn As Range
    With ActiveSheet
        Dim y As Long
        y = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
        Set GetMainRange = .Range(ActiveCell, .Cells(y, ActiveCell.Column + MAN_COLUMN - 1))
    End With
End Function

Private Sub JobMainRange()
    If rnMain.Columns.Count < MAN_COLUMN Then Exit Sub
    arrMain = rnMain
    Dim dicMan As Variant
    dicMan = GetDicMan(arrMain)

    Dim man As Variant
    For Each man In dicMan
        FillArrOneMan man
        JobNewWb man
    Next
End Sub

Private Sub JobNewWb(ByVal man As String)
    Application.StatusBar = man

    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(UBound(arrOneMan, 1), UBound(arrOneMan, 2))
        .NumberFormat = "@"
        .Value = arrOneMan
        .NumberFormat = "General"

        Dim x As Integer
        For x = 1 To .Columns.Count
            .Columns(x).ColumnWidth = rnMain.Columns(x).ColumnWidth
        Next
    End With

    Dim sFull As String
    sFull = ThisWorkbook.Path & "\" & man & ".xlsx"
    On Error Resume Next
    Workbooks(man & ".xlsx").Close False
    Kill sFull
    Err.Clear
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err = 0 Then
        wb.Close False
    Else
        wb.Saved = True
    End If
    On Error GoTo 0

    Application.StatusBar = False
End Sub

Private Sub FillArrOneMan(ByVal man As String)
    ReDim arrOneMan(1 To UBound(arrMain, 1), 1 To UBound(arrMain, 2))
    FillRow 1, 1

    Dim y As Long
    Dim u As Long
    u = 1
    For y = 2 To UBound(arrMain, 1)
        If arrMain(y, MAN_COLUMN) = man Then
            u = u + 1
            FillRow y, u
        End If
    Next
End Sub

Private Sub FillRow(rowFrom As Long, rowTo As Long)
    Dim x As Integer
    For x = 1 To UBound(arrOneMan, 2)
        arrOneMan(rowTo, x) = arrMain(rowFrom, x)
    Next
End Sub

Private Function GetDicMan(arr As Variant) As Variant
    Dim dic As Variant
    Dim y As Long
    For y = 2 To UBound(arr, 1)
        If Not ExistsInArr(dic, arr(y, MAN_COLUMN)) Then
            If IsEmpty(dic) Then
                ReDim dic(0 To 0)
            Else
                ReDim Preserve dic(LBound(dic) To UBound(dic) + 1)
            End If
            dic(UBound(dic)) = arr(y, MAN_COLUMN)
        End If
    Next

    GetDicMan = dic
End Function

Private Function ExistsInArr(arr As Variant, vl As Variant) As Boolean
    If Not IsEmpty(arr) Then
        Dim v As Variant
        For Each v In arr
            If v = vl Then
                ExistsInArr = True
                Exit For
            End If
        Next
    End If
End Function
Изменено: МатросНаЗебре - 18.01.2022 13:51:26
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Попробовал убрать selection. Вместо выделения, станьте на верхний левый угол диапазона.
Если не сработает, нужно будет поспрашивать у знающих Mac людей, например, на этом же форуме, как адаптировать.
Код
Option Explicit
Const MAN_COLUMN = 21
Dim rnMain As Range
Dim arrMain As Variant
Dim arrOneMan As Variant

Sub MakeManagersFiles()
    'Range("A2:H271").Select
    Set rnMain = GetMainRange()
    JobMainRange
End Sub

Private Function GetMainRange() As Range
    Dim rn As Range
    With ActiveSheet
        Dim y As Long
        y = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
        Set GetMainRange = .Range(ActiveCell, .Cells(y, ActiveCell.Column + MAN_COLUMN - 1))
    End With
End Function

Private Sub JobMainRange()
    If rnMain.Columns.Count < MAN_COLUMN Then Exit Sub
    arrMain = rnMain
    Dim dicMan As Object
    Set dicMan = GetDicMan(arrMain)
    
    Dim man As Variant
    For Each man In dicMan.Keys
        FillArrOneMan man
        JobNewWb man
    Next
End Sub

Private Sub JobNewWb(ByVal man As String)
    Application.StatusBar = man
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(UBound(arrOneMan, 1), UBound(arrOneMan, 2))
        .NumberFormat = "@"
        .Value = arrOneMan
        .NumberFormat = "General"
        
        Dim x As Integer
        For x = 1 To .Columns.Count
            .Columns(x).ColumnWidth = rnMain.Columns(x).ColumnWidth
        Next
    End With
    
    Dim sFull As String
    sFull = ThisWorkbook.Path & "\" & man & ".xlsx"
    On Error Resume Next
    Workbooks(man & ".xlsx").Close False
    Kill sFull
    Err.Clear
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err = 0 Then
        wb.Close False
    Else
        wb.Saved = True
    End If
    On Error GoTo 0
    
    Application.StatusBar = False
End Sub

Private Sub FillArrOneMan(ByVal man As String)
    ReDim arrOneMan(1 To UBound(arrMain, 1), 1 To UBound(arrMain, 2))
    FillRow 1, 1
    
    Dim y As Long
    Dim u As Long
    u = 1
    For y = 2 To UBound(arrMain, 1)
        If arrMain(y, MAN_COLUMN) = man Then
            u = u + 1
            FillRow y, u
        End If
    Next
End Sub

Private Sub FillRow(rowFrom As Long, rowTo As Long)
    Dim x As Integer
    For x = 1 To UBound(arrOneMan, 2)
        arrOneMan(rowTo, x) = arrMain(rowFrom, x)
    Next
End Sub

Private Function GetDicMan(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 2 To UBound(arr, 1)
        dic.Item(arr(y, MAN_COLUMN)) = 0
    Next
    
    Set GetDicMan = dic
End Function
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
А без изменений кода на первоначальном примере работает?

Как вариант можно попробовать не удалять строку
Код
Range("A2:H271").Select

а изменить в ней диапазон.
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
А выделяете какое-то определённое количество строк?
В смысле не столбец целиком?
Например, 21 столбец и 100 строк?

А ошибка из снимка экрана какая-то неожиданная. Пишет, что нет лицензии на какой-то компонент. Хотя все компоненты входят в стандартную поставку.
А в чём работаете? В Excel?
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Выделили диапазон?
Тот, в котором 21 столбец?
Создание листов из 2х исходных таблиц с поиском по значению, Извините, если со свиным рылом в калашный ряд
 
Пишу в личку.
Сделал.
Оплату получил.
Изменено: МатросНаЗебре - 18.01.2022 12:56:30
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Цитата
написал:
думаю еще вариант с формулой попробовать.
Цитата
написал:
Но у меня на сегодняшний день уже больше 500 тыс строк))) и как быстро это все работать будет, слабо представляю
Работать будет медленно. Лучше чуть поднапрячься и освоить макрос.
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Можно вставить в любой файл.
Например, создайте пустой файл. Вставьте в него код.
Сохраните, например, в пустую папку.

Откройте файл с данными. В примере это был файл Пример планета_6.xlsx.
Запустите макрос MakeManagersFiles. (Alt+F8 ...).
В папку, в которой расположен файл с макросом, будут сохранены файлы по менеджерам.
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Подгрузить не получается. Думаю, поможет это:
Как вставить готовый макрос в рабочую книгу (office-guru.ru)
Листайте до "Как добавить готовый макрос в рабочую книгу".

Разобраться просто.
Макрос сейчас работает по фиксированному диапазону "A2:H271".
Удалите в коде строку
Код
Range("A2:H271").Select

И макрос будет работать по выделенному диапазону.
Сортировка и перенос данных из одной общей таблицы по разным файлам
 
Ещё вариант.
Код
Option Explicit
Const MAN_COLUMN = 8
Dim rnMain As Range
Dim arrMain As Variant
Dim arrOneMan As Variant

Sub MakeManagersFiles()
    Range("A2:H271").Select
    Set rnMain = Selection
    JobMainRange
End Sub

Private Sub JobMainRange()
    If rnMain.Columns.Count < 8 Then Exit Sub
    arrMain = rnMain
    Dim dicMan As Object
    Set dicMan = GetDicMan(arrMain)
    
    Dim man As Variant
    For Each man In dicMan.Keys
        FillArrOneMan man
        JobNewWb man
    Next
End Sub

Private Sub JobNewWb(ByVal man As String)
    Application.StatusBar = man
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1).Cells(1, 1).Resize(UBound(arrOneMan, 1), UBound(arrOneMan, 2))
        .NumberFormat = "@"
        .Value = arrOneMan
        .NumberFormat = "General"
        
        Dim x As Integer
        For x = 1 To .Columns.Count
            .Columns(x).ColumnWidth = rnMain.Columns(x).ColumnWidth
        Next
    End With
    
    Dim sFull As String
    sFull = ThisWorkbook.Path & "\" & man & ".xlsx"
    On Error Resume Next
    Workbooks(man & ".xlsx").Close False
    Kill sFull
    Err.Clear
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    If Err = 0 Then
        wb.Close False
    Else
        wb.Saved = True
    End If
    On Error GoTo 0
    
    Application.StatusBar = False
End Sub

Private Sub FillArrOneMan(ByVal man As String)
    ReDim arrOneMan(1 To UBound(arrMain, 1), 1 To UBound(arrMain, 2))
    FillRow 1, 1
    
    Dim y As Long
    Dim u As Long
    u = 1
    For y = 2 To UBound(arrMain, 1)
        If arrMain(y, MAN_COLUMN) = man Then
            u = u + 1
            FillRow y, u
        End If
    Next
End Sub

Private Sub FillRow(rowFrom As Long, rowTo As Long)
    Dim x As Integer
    For x = 1 To UBound(arrOneMan, 2)
        arrOneMan(rowTo, x) = arrMain(rowFrom, x)
    Next
End Sub

Private Function GetDicMan(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 2 To UBound(arr, 1)
        dic.Item(arr(y, MAN_COLUMN)) = 0
    Next
    
    Set GetDicMan = dic
End Function
Действие при нажатии на кнопку "Отмена" и проверка, что вводимое значение "не пусто", в InputBox в ходе выполнения макроса
 
Код
Do
    str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
    
    If str2 = False Then
        'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
        MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
        Exit Sub
    End If
    
    If str2 <> "" Then Exit Do
    MsgBox "такое название необходимо ввести", vbCritical, "Информационное сообщение"
Loop
Объединение строк в одну по уникальным значениям в столбце, Объеденение дубликатов в столбце, с последующим сопоставлением строк
 
Код
Исходник!P2:Y35      =ЕСЛИ($A3<>"";ЕСЛИ(ЕПУСТО(E2);"";E2);ЕСЛИ(E2="";ЕСЛИ(ЕПУСТО(P3);"";P3);E2))
Итог!A2:D6           =ВПР(СТРОКА(1:1);Исходник!$A:$Y;СТОЛБЕЦ();0)
Итог!E2:N6           =ВПР(СТРОКА(1:1);Исходник!$A:$Y;СТОЛБЕЦ()+11;0)
Постановка макроса в очередь срабатывания при параллельном запуске макросов в двух разных сессиях
 
Цитата
написал:
часть кода, которая Проверяла бы, работает ли в настоящий момент при этом другой макрос
Как вариант, в другом макросе создавать текстовый файл, по которому первый макрос будет понимать, что макрос работает/завершил работу.
Изменено: МатросНаЗебре - 17.01.2022 12:21:03
Действие при нажатии на кнопку "Отмена" и проверка, что вводимое значение "не пусто", в InputBox в ходе выполнения макроса
 
Код
Do
    str2 = Application.InputBox(Prompt:="наименование столбца со значением", Title:="Укажите...", Type:=2)
    If str2 <> "" Then Exit Do
    MsgBox "такое название необходимо ввести", vbCritical, "Информационное сообщение"
    If str2 = False Then
    'Вывод информационного окна с сообщением при нажатии кнопки "Отмена"
    MsgBox "Отмена преобразования данных!", vbCritical, "Информационное сообщение"
    Exit Sub
    End If
Loop
По двум критериям (квоте и по факту) найти нужный балл
 
Цитата
написал:
функция СЧЕТ в конце формулы
Определяет количество столбцов в строке, в которой идёт поиск.
По двум критериям (квоте и по факту) найти нужный балл
 
Код
=ИНДЕКС(C4:Q4;ПОИСКПОЗ(I29;СМЕЩ($B$4;ПОИСКПОЗ($I$28;$B$5:$B$19;0);0;1;1+1*СЧЁТ($B$4:$Q$4));-1))
Применить макрос ко всем файлам папки
 
Код
Option Explicit

Public fso As Object

Sub FixFiles()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim arrFiles As Variant
    arrFiles = ShowFileDialog()
    If IsEmpty(arrFiles) Then Exit Sub
    Dim wb As Workbook
    Dim vFile As Variant
    For Each vFile In arrFiles
        If fso.GetExtensionName(vFile) = "csv" Then
            FixCSVFile vFile
        Else
            Set wb = Workbooks.Open(vFile)
            FixFile wb
            wb.Close True
        End If
    Next
End Sub

Sub FixCSVFile(ByVal sFull As String)
    Dim txt As String
    With fso.OpenTextFile(sFull, 1)
        txt = .ReadAll
        .Close
    End With
    
    Dim v As Variant
    For Each v In Array("=", """")
        txt = Replace(txt, v, "")
    Next

    With fso.OpenTextFile(sFull, 2)
        .Write txt
        .Close
    End With
End Sub
 
Sub FixFile(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        FixSheet sh
    Next
End Sub
 
Sub FixSheet(sh As Worksheet)
    With sh.UsedRange
        .NumberFormat = "@"
        Dim arr As Variant
        arr = .Value
        .Value = arr
        .NumberFormat = "General"
    End With
End Sub
 
Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.csv", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
    End With
    ShowFileDialog = arr
End Function
Множественные совпадения ВПР
 
N2:N17    
Код
=ЕСЛИОШИБКА(ВПР(H2;H3:N$18;7;0);СЧЁТЕСЛИМН($H$1:$H$17;H2)+1)-1
В L2 ввести формулу массива (Ctrl+Shift+Enter) и протянуть
Код
=ИНДЕКС($I$1:$I$17;СУММ((K2=$H$1:$H$17)*(СЧЁТЕСЛИМН($K$1:K2;K2)=$N$1:$N$17)*СТРОКА($H$1:$H$17)))
Изменено: МатросНаЗебре - 17.01.2022 10:11:54
Выделение ячейки цветом при повторе значения
 
Пишу в личку.
Не претендую, заказ свободен.
Изменено: МатросНаЗебре - 17.01.2022 17:34:45
Макрос: удаление строк на другом листе по условию (без совпадения - удалить)
 
Код
Option Explicit
Dim wbOut As Workbook
Dim dicID As Object
    
Sub DelRows()
    Dim wbFrom As Workbook
    Set wbFrom = ActiveWorkbook
    
    Set dicID = GetDicID(wbFrom.Sheets("Products"))
    
    Set wbOut = Workbooks.Add(1)
    
    Dim sheetName As Variant
    Dim sh As Worksheet
    For Each sheetName In Array("ProductOptions", "ProductOptionValues")
        On Error Resume Next
        Set sh = wbFrom.Sheets(sheetName)
        On Error GoTo 0
        If Not sh Is Nothing Then
            CopySheet sh
            Set sh = Nothing
        End If
    Next
    
    FinalizeWbOut wbOut
End Sub

Private Sub FinalizeWbOut(wbOut As Workbook)
    With wbOut
        If .Sheets.Count > 1 Then
            Application.DisplayAlerts = False
            .Sheets(1).Delete
            Application.DisplayAlerts = True
        End If
        
        .Saved = True
    End With
End Sub

Private Sub CopySheet(sh As Worksheet)
    sh.Copy After:=wbOut.Sheets(wbOut.Sheets.Count)
    
    With ActiveSheet
        Dim arr As Variant
        Dim orr As Variant
        Dim rUsedRange As Range
        Set rUsedRange = .UsedRange
        arr = rUsedRange
        ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        
        Dim x As Integer
        Dim y As Long
        Dim u As Long
        For y = 1 To UBound(arr, 1)
            If dicID.Exists(arr(y, 1)) Then
                u = u + 1
                For x = 1 To UBound(arr, 2)
                    orr(u, x) = arr(y, x)
                Next
            End If
        Next
        Erase arr
            
        .Cells.ClearContents
        rUsedRange = orr
    End With
End Sub

Private Function GetDicID(sh) As Object
    Dim arr As Variant
    With sh
        arr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 2))
    End With
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(arr, 1)
        dic.Item(arr(y, 1)) = 0
    Next
    
    Set GetDicID = dic
End Function
I suppose I didn't screwed plans about realization of that TR.
Авто ввод остатка при вводе товара, для учета инвентаря
 
Код
=ЕСЛИОШИБКА(СМЕЩ($G$1;МАКС((B8=$B$1:B7)*СТРОКА($B$1:B7))-1;0);0)
Вводить как формулу массива Ctrl+Shift+Enter.
Пример лучше приводить в формате xls*
Извлечь из текста ИНН и КПП
 
Код
=ПСТР(RC1;НАЙТИ(R1C;RC1)+5;НАЙТИ(СИМВОЛ(10);RC1;НАЙТИ(R1C;RC1))-НАЙТИ(R1C;RC1)-5)
Распределить номера платежей по комплектам
 
Код
F2:F9        =ПСТР(СЦЕПИТЬ(I11;J11;K11;L11;M11);2;10000)
G2:G9        =СУММ($D$1:$D2)
I2:M9        =ЕСЛИ(СТОЛБЕЦ()-СТОЛБЕЦ($H:$H)<=$G2-$G1;МАКС($H$1:$M1;$H2:H2)+1;"")
I11:M18      =ЕСЛИ(I2="";"";","&ИНДЕКС($A$2:$A$19;I2))
ВПР + СУММ, Суммировать данные найденные по впр
 
Код
=СУММ(($B24='Норма. Газ счетчик'!$F$3:$F$10)*(D$1='Норма. Газ счетчик'!$J$1:$U$1)*'Норма. Газ счетчик'!$J$3:$U$10)
Вводите как формулу массива Ctrl+Shift+Enter
Найти числа в ячейках с числами и текстом
 
Ну или вариант попроще обычной формулой )
Код
=ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");1;1));0)+ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");2;1));0)+ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");3;1));0)+ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ(СТРОЧН(ПЕЧСИМВ(A2));"а";"");"б";"");"в";"");"г";"");"д";"");"е";"");"ж";"");"з";"");"и";"");"й";"");"к";"");"л";"");"м";"");"н";"");"о";"");"п";"");"р";"");"с";"");"т";"");"у";"");"ф";"");"х";"");"ц";"");"ч";"");"ш";"");"щ";"");"ъ";"");"ы";"");"ь";"");"э";"");"ю";"");"я";"");" ";"");"-";"");".";"");"!";"");"?";"");4;1));0)
Сортировка/фильтрация ячеек вне умной таблицы
 
Код
Option Explicit

Const EXTRA_COLUMNS_COUNT = 2
Const SORT_COLUMN_INDEX = 2

Sub SortTableExtraRange()
    Dim tb As ListObject
    Set tb = GetListObject(ActiveCell)
    If Not tb Is Nothing Then
        Dim tb_Columns_Count As Long
        tb_Columns_Count = tb.DataBodyRange.Columns.Count
        Dim rSort As Range
        Set rSort = tb.DataBodyRange.Resize(, tb_Columns_Count + EXTRA_COLUMNS_COUNT)
        
        Application.ScreenUpdating = False
        
        SortRange rSort
        RestoreListObject tb, tb_Columns_Count
        
        Application.ScreenUpdating = True
        
    End If
End Sub

Sub RestoreListObject(tb As ListObject, tb_Columns_Count As Long)
    tb.Resize tb.Range.Resize(, tb_Columns_Count)
End Sub

Sub SortRange(rSort As Range)
    Dim arr As Variant
    arr = rSort
    
    Dim rn As Range
    Set rn = Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
    rn.Value = arr
    
    With rn.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rn.Columns(SORT_COLUMN_INDEX), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange rn
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    arr = rn
    rn.Parent.Parent.Close False
    rSort = arr
End Sub

Function GetListObject(cl As Range) As ListObject
    Dim tb As ListObject
    For Each tb In cl.Parent.ListObjects
        If Not Intersect(tb.Range, cl) Is Nothing Then
            Set GetListObject = tb
            Exit Function
        End If
    Next
End Function
Применить макрос ко всем файлам папки
 
Код
Option Explicit

Sub FixFiles()
    Dim arrFiles As Variant
    arrFiles = ShowFileDialog()
    If IsEmpty(arrFiles) Then Exit Sub
    Dim wb As Workbook
    Dim vFile As Variant
    For Each vFile In arrFiles
        Set wb = Workbooks.Open(vFile)
        FixFile wb
        wb.Close True
    Next
End Sub

Sub FixFile(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        FixSheet sh
    Next
End Sub

Sub FixSheet(sh As Worksheet)
    With sh.UsedRange
        .NumberFormat = "@"
        Dim arr As Variant
        arr = .Value
        .Value = arr
        .NumberFormat = "General"
    End With
End Sub

Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
    End With
    ShowFileDialog = arr
End Function
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 135 След.
Наверх