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

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 15 След.
Не работает выделятор., Compile error in hidden module: frmSelector
 
Как там написано, надо разблокировать модули макросов (редактор vba ALT + F11 => Tools\VBAProject Properties => введите пароль) и проверить, где в коде появляется ошибка.
Как транспорировать данные
 
Код
Option Explicit

Sub aaa()
    Dim a, b, c, i&, j&, k&
    
    a = Sheets("Исходные данные").Range("A1").CurrentRegion.Value
    ReDim b(1 To ((UBound(a, 2) - 2) * (UBound(a, 1) - 1)) + 1, 1 To 4)
    c = Array("Артикул", "Дата", "Ключевое слово", "Позиция")
    k = 1
    
    For i = 1 To 4
        b(k, i) = c(i - 1)
    Next
    For j = 3 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            k = k + 1
            b(k, 1) = a(i, 1)
            b(k, 2) = a(1, j)
            b(k, 3) = a(i, 2)
            b(k, 4) = a(i, j)
        Next
    Next
    
    With Sheets("Исходные данные")
        With .Range("A1")
            .CurrentRegion.ClearContents
            .Resize(UBound(b, 1), 4).Value = b
        End With
    End With
End Sub
Как проверить не занята ли книга другим пользователем, VBA
 
Например, это может быть так (?):

1. Модуль "ThisWorkbook" файла "workbook.xlsm"
Код
Option Explicit

'Какой-то сетевой каталог для временных файлов
'Необходима консультация по теме с сетевым администратором
Const pthind As String = "Z:\TEMP\Indicators\ForXls\fleopn.txt"

Private Sub Workbook_Open()
    Dim n As Byte: n = FreeFile(0)
    Reset
    On Error Resume Next
    Open pthind For Output Access Write Lock Write As #n
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Reset
    On Error Resume Next
    Kill pthind
End Sub
2. Процедура «автоматического» открытия «workbook.xlsm» в другом файле
Код
Option Explicit

Const pthind As String = "Z:\TEMP\Indicators\ForXls\fleopn.txt"
Const pthwbk As String = "C:\path\workbook.xlsm"

Sub abc_xyz()
    Dim xlap As Object, xlwb As Object
    
    If Len(Dir(pthind, vbNormal)) > 0 Then
        On Error Resume Next
            Kill pthind
            If Err.Number <> 0 Then
                MsgBox "Запись запрещена, файл используется": Exit Sub
            End If
        On Error GoTo 0
    End If
    
    Set xlap = CreateObject("Excel.Application")
    xlap.Visible = True
    Set xlwb = xlap.Workbooks.Open(pthwbk)
    '... Какой-то код
    xlwb.Close True: Set xlwb = Nothing
    xlap.Quit: Set xlap = Nothing
End Sub
VBA. Как найти строку по нескольким критериям?, VBA
 
Цитата
написал:
оптимизировать
Код
Option Explicit

Sub xyz_0()
    Dim a, crt As String, i As Long, p
    
    With ThisWorkbook.Sheets("List1")
        a = .Range("A1:E" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
        crt = Join(Application.Index(.Range("F3:H3").Value, 0), vbNullString)
        
        For i = 1 To UBound(a, 1)
            a(i, 5) = a(i, 1) & a(i, 2) & a(i, 3)
        Next
        
        p = Application.Match(crt, Application.Index(a, 0, 5), 0)
        If Not IsError(p) Then .Range("I3").Value = a(p, 4)
    End With
End Sub

Sub xyz_1()
    Dim a, crt As String, i As Long
    
    With ThisWorkbook.Sheets("List1")
        a = .Range("A1:D" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
        crt = Join(Application.Index(.Range("F3:H3").Value, 0), vbNullString)
        
        For i = 1 To UBound(a, 1)
            If a(i, 1) & a(i, 2) & a(i, 3) = crt _
            Then .Range("I3").Value = a(i, 4): Exit For
        Next
    End With
End Sub
VBA RegEx макрос для .docx (или для строки в ячейке Excel), Замена значений в тексте
 
А может так ?
Код
Option Explicit

Sub abcdf()
    Dim i As Long, fnd As String, rplc As String, txtrng As Object
    
    Selection.HomeKey Unit:=wdStory
    
    Set txtrng = ActiveDocument.Range
    txtrng.Find.ClearFormatting
    txtrng.Find.Replacement.ClearFormatting
    
    Do While txtrng.Find.Execute(FindText:="ref\[*\]ref", MatchWildcards:=True)
        i = i + 1
        rplc = "[" & i & "]"
        fnd = ActiveDocument.Range(Start:=txtrng.Start, End:=txtrng.End).Text
        txtrng.Find.Execute FindText:=fnd, MatchWholeWord:=True, MatchWildcards:=False, _
                        Forward:=True, Wrap:=wdFindContinue, ReplaceWith:=rplc, _
                        Replace:=wdReplaceAll
    Loop
End Sub
Добавить в ячейку текст из активного (выбранного) TextBox, VBA
 
Вариант:
Код
Option Explicit

Private tbnme As String

Private Sub UserForm_Initialize()
    Dim i As Long
    
    For i = 1 To 10
        UserForm1.ListBox1.AddItem "Zapis' - " & i
    Next
End Sub

'Private Sub TextBox1_Enter()
'    tbnme = "TextBox1"
'End Sub

'Private Sub TextBox2_Enter()
'    tbnme = "TextBox2"
'End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    tbnme = "TextBox1"
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    tbnme = "TextBox2"
End Sub

Private Sub CommandButton1_Click()
    Dim txt As String
    
    If Len(tbnme) = 0 Then Exit Sub
    txt = Me.Controls(tbnme).Value
    
    MsgBox "Tekushchiy 'TextBox' eto: " & Chr(34) & tbnme & Chr(34) & vbNewLine & _
           "a tekst eto: '" & txt & "'"
End Sub
Преобразование дат из текстового формата в числовой
 
???
Код
ДАТА(ЗНАЧЕН(ЛЕВСИМВ($B1;4));ПОИСКПОЗ(ПРАВСИМВ($B1;ДЛСТР($B1)-НАЙТИ(" ";СЖПРОБЕЛЫ($B1);6));{"январь";"февраль";"март";"апрель";"май";"июнь";"июль";"август";"сентябрь";"октябрь";"ноябрь";"декабрь"};0);1)
???
Подставить в ячейку текст в зависимости от текста в другой ячейке
 
Русских названий функций не знаю полностью, но может быть то так ?

В "B1":

=ВПР(ЛЕВСИМВ($A1;2);$D$3:$E$5;2;0)

и скопируйте вниз.
Макрос скопировать значение только первой строки результата автофильтра
 
Цитата
  abutov написал:
скопировать значение только первой строки результата автофильтра
Код
Sub aaa()
    Dim rg As Range, frd As Range
    
    Set rg = Range("A1").CurrentRegion
    rg.AutoFilter Field:=2, Criteria1:="<0"
    On Error Resume Next
        With rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
            Set frd = .SpecialCells(xlCellTypeVisible).Areas(1).Rows(1)
        End With
    On Error GoTo 0
    rg.AutoFilter
    If Not frd Is Nothing Then
        Range("D2:E2").Value = Array(Application.Min(frd), Application.Max(frd))
        Set frd = Nothing
    End If
    Set rg = Nothing
End Sub
Цикл For Each в обратном порядке, VBA
 
Можно тоже использовать свойство "Areas" объекта "Range":
Код
Sub xyz()
    Dim i&, rg As Range
    
    With ActiveSheet
        Set rg = .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
        
        For i = rg.Areas.Count To 1 Step -1
            'With rg.Areas(i).Range("A1")
            'With rg.Areas(i).Cells(1)
            With rg.Areas(i)
                .Select
                .Interior.ColorIndex = 9 - i
            End With
            Application.Wait (Now + TimeValue("00:00:02"))
        Next
        
        .Range("A1").CurrentRegion.Interior.ColorIndex = xlNone 'xlColorIndexNone
    End With
    
    Set rg = Nothing
End Sub
Макрос удаление символов в начале строки, Как удалить определенные символы в начале строки?
 
Цитата
написал:
ocet p , у меня на 1млн строк ("X123") вот так

на моей "машиночке" всё в три-четыре раза длиннее работает, она уже старинная - ваша это "быстрая машина"

Цитата
написал:
спасибо за науку!
рад, что привнес что-то в тему
спасибо за тесты
Макрос удаление символов в начале строки, Как удалить определенные символы в начале строки?
 
такой вариант:
Код
Function cipcip$(ByVal sval$, sdel$)
    Dim asdel&: asdel = AscW(sdel)
    Do While AscW(sval) = asdel
        sval = Right$(sval, Len(sval) - 1)
    Loop
    cipcip = sval
End Function
время перехода при обработке данных (1 миллион строк) в переменной массива:
"всасывание" данных в массив: 0,2 s
удаление символов: 1,4 s
ввод данных в лист: 5,4 s

запуск/вызов (?) функции (на основе одного символа - не подходит для "смешанных символов", таких как: Xa, Xx, и т. д.):
Код
Sub picpic()
    Dim t!: t = Timer
    Const strd$ = "X"
    Dim a, i&
    
    With ActiveSheet
        a = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    End With
        'Debug.Print Round(Timer - t, 3)
        For i = 1 To UBound(a, 1)
            a(i, 1) = cipcip(a(i, 1), strd)
        Next
        'Debug.Print Round(Timer - t, 3)
    With ActiveSheet
        .Range("B1:B" & i - 1).Value = a
    End With
    'Debug.Print Round(Timer - t, 3)
End Sub
Открыть последний файл в папке по маске не по дате сохранения
 
Может так ?
Код
Option Explicit

Sub IvanovIvanIvanovich()
    Const pth$ = "C:\Temp\Papka\"
    Const pttrn$ = "??.??.????_*.xlsx" ' 18.10.2022_IvanovIvanIvanovich.xlsx
    
    Dim d, cdte As Date, fle$, s, mdte&, mfle$
    
    cdte = Date
    mdte = 10000000
    fle = Dir(pth & pttrn, vbNormal)
    
    Do Until Len(fle) = 0
        s = Split(Split(fle, "_", 2, 0)(0), ".", 3)
        d = cdte - DateSerial(s(2), s(1), s(0))
        If Not IsError(d) Then
            If d < mdte Then mdte = d: mfle = fle
        End If
        fle = Dir()
    Loop
    
    If TypeName(ActiveSheet) = "Worksheet" Then
        ActiveSheet.Range("A2:B2").Value = Array(mdte, mfle)
    End If
End Sub
VBA Excel Добавление нумерации внутри ячейки с данными
 
А куда вы вводите свои данные сейчас и в каком порядке ?
В столбце А нет никакой нумерации.
Упрощение записи VBA, Упрощение записи VBA при наличии множества TextBox и ссылок на ячейки, размещенные по порядку номеров
 
Цитата
написал:
как можно упростить подобную запись
Цитата
написал:
можно так
А если нумерация для «TextBox» и «Range» не является непрерывной, вы можете как ниже:
Код
    Dim i As Long
    Dim ctrls, rgs
    
    With Me
        ctrls = Array(.TextBox1, .TextBox2, .TextBox3, .TextBox4, .TextBox5, .TextBox6, _
                      .TextBox7, .TextBox8, .TextBox9, .TextBox10, .TextBox11, .TextBox12, _
                      .TextBox13, .TextBox14, .TextBox15, .TextBox16, .TextBox17, .TextBox18, _
                      .TextBox19)
    End With
    
    rgs = Array("C2", "C3", "C4", "C5", "C6", "C7", "C8", "C9", "C10", "C11", _
                "C12", "C13", "C14", "C15", "C16", "C17", "C18", "C19", "C20")
    
    For i = LBound(ctrls) To UBound(ctrls)
        ctrls(i).Value = List.Range(rgs(i)).Value
    Next
Удаление строк с 0 значением в ячейках определенного столбца во всех листах., нужен макрос на удаление строк с 0 значение в ячейке во всех листах
 
Вариант:
Код
Option Explicit

Sub курочка_ряба()
    Dim ws As Object
    On Error Resume Next
    For Each ws In Worksheets
        With ws
            If .Name <> "Заказ" Then
            'If .Visible Then
                With .Range("A6:F42")
                    .AutoFilter Field:=6, Criteria1:="0"
                    With .Offset(1, 0).Resize(.Rows.Count - 1)
                        .SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
                    End With
                    If Err.Number <> 0 Then Err.Clear
                    .AutoFilter
                End With
            End If
        End With
    Next
End Sub
Формула VLOOKUP через VBA с искомой переменной, вместо фииксированной ячейки
 
Вы это имели в виду ?

Код
Option Explicit

Sub V_LOOK_UP()
    Const rngadrs = "$A$1:$B$34"
    Const shnme = "Source"
    
    Dim adrs As String, frmla As String
    
    adrs = Application.InputBox("Select a Cell", Type:=8).Address(0, 0)
    frmla = "=VLOOKUP(" & "$" & adrs & "," & shnme & "!" & rngadrs & ",2,0)"
    
    Range(adrs).Offset(0, 1).Formula = frmla
End Sub
Указать список значений для ComboBox, Как переделать 1|2|3|4|5 в Array("1", "2", "3", "4", "5", "6")
 
Цитата
Юрий написал:
Как переделать 1|2|3|4|5 в Array("1", "2", "3", "4", "5", "6")
Можно тоже таким образом:
Код
Option Explicit

Sub UserForm_Initialize()
    Dim strval As Variant
    
    strval = "1|2|3|4|5|6"
    
    strval = "{" & Replace(strval, "|", ",", 1, -1, 1) & "}"
    strval = Evaluate(strval)
    
    Me.ComboBox4.List() = strval
End Sub
Разбивка по строкам
 
Вариант, для размещения данных как на изображении:

Код
Option Explicit

Sub razbivka_po_strokam()
    Const dlm = ","
    
    Dim i&, ii&, j&, jj&, k&, n&
    Dim arr, splt, tbl
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    With Range("A1").CurrentRegion
        arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
    End With
    
    ii = UBound(arr, 1): jj = UBound(arr, 2)
    For i = 1 To ii
        j = j + UBound(Split(arr(i, 7), dlm, -1, 0)) + 1
    Next
    ReDim tbl(1 To j, 1 To jj)
    jj = jj - 1
    
    For i = 1 To ii
        splt = Split(arr(i, 7), dlm, -1, 0)
        For n = 0 To UBound(splt)
            k = k + 1
            For j = 1 To jj
                tbl(k, j) = arr(i, j)
            Next
            tbl(k, j) = splt(n)
        Next
    Next
    
    arr = Empty: splt = Empty
    Range("A2").Resize(k, jj + 1).Value = tbl
    tbl = Empty
    
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Изменение связей с группой файлов за один раз
 
?
Но это не схема именования, описанная в шаге 1.
Что еще изменится ?
: )
Изменение связей с группой файлов за один раз
 
Цитата
Kiboiashi Kimomoro написал:
170 файлов формата *.xls типа: 01_2020_01_10.xls
Почему схема именования файлов - "01_2020_01_10.xls", а не "001_2020_01_10.xls" ?
Файлов 170, поэтому должно быть "001_" (до "170_") в префиксе, а не "01_".
Вставка значений ячеек в формулу, VBA Excel
 
Цитата
Ігор Гончаренко написал:
это одно и то же
Подумайте, прежде чем писать что-нибудь.
Если ячейки, в которые должны быть скопированы данные, будут отличатся (от тех, которые я ввел), это то же самое для вас ?
Например:
Код
t_o = Array("AA1", "AA2", "AA3", "AA4", "AA5", "AA6", "AA7", "AA8", "AA9", "AA10")

'или

t_o = Array("B1", "E2", "J3", "D4", "A5", "Z6", "X7", "U8", "F9", "I10")

'и так далее
Вставка значений ячеек в формулу, VBA Excel
 
Это можно бы сделать по этой схеме:

Код
Option Explicit

Sub a_b_frml()
    
    Const xlALst = "List1" 'Otkuda
    Const xlBLst = "List1" 'Gde
    Const prcsn = "3"      'Tochnost' rezul'tata v formule
    
    Dim f_rm: f_rm = Application.GetOpenFilename("Fayle xls (*.xls*),*.xls*", , "Otkuda")
            If f_rm = False Then Exit Sub
    Dim t_o: t_o = Application.GetOpenFilename("Fayle xls (*.xls*),*.xls*", , "Gde")
            If t_o = False Then Exit Sub
    
    Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
            Dim wkA As Workbook: Set wkA = Workbooks.Open(f_rm, 0, True) 'Otkuda
            Dim wkB As Workbook: Set wkB = Workbooks.Open(t_o, 0, False) 'Gde
        Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    
    f_rm = Array("A1", "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9", "A10")        'yacheyki - otkuda
    t_o = Array("A1", "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9", "A10")         'yacheyki - gde
    Dim d: d = Array("1.1", "0.9", "2.4", "3.9", "4.2", "5", "6.7", "7.8", "8", "9") 'deliteli chisel
    
    Dim ix As Long: ix = LBound(f_rm)
    Dim iy As Long: iy = UBound(f_rm)
    Dim i As Long, tbl: ReDim tbl(ix To iy)
    
    For i = ix To iy
        tbl(i) = wkA.Sheets(xlALst).Range(f_rm(i)).Value
        If Not IsNumeric(tbl(i)) Then tbl(i) = Val(Replace(tbl(i), ",", ".", 1, -1, 0))
    Next
    
    wkA.Close False: Set wkA = Nothing
    
    Application.ScreenUpdating = False
        For i = ix To iy
            wkB.Sheets(xlBLst).Range(t_o(i)).Formula = "=ROUND(" & tbl(i) & "/" & d(i) & "," & prcsn & ")"
        Next
    Application.ScreenUpdating = True
    
    Set wkB = Nothing
    
End Sub
Преобразовать текст в число с помощью макроса
 
Может что-то подобное у вас сработает ?

Код
Sub abc_xyz()
    Range("E6:E300").Value = Range("E6:E300").Value
End Sub
Создание файлов по шаблону с сохранением в новую папку, оптимизация кода для увеличение скорости
 
1. "Workbooks("2.xlsm")" - это  в вашем коде, то же самое, что "ThisWorkbook" ?
2. Инструкция "For i = 4 To 48 'Запускаем цикл на 44 строки, начиная с четвертой строки"
Для этой инструкции это 45 строк, не 44 строки.
3. "как разорвать все связи без пути?"
Это зависит от того, какие это ссылки, связи - например:
Код
Dim arrlnks, i As Long, wB As Workbook
Set wB = ActiveWorkbook
arrlnks = wB.LinkSources(Type:=xlLinkTypeExcelLinks)

If Not IsEmpty(arrlnks) Then
    For i = 1 To UBound(arrlnks)
        wB.BreakLink Name:=arrlnks(i), Type:=xlLinkTypeExcelLinks
    Next
End If

ActiveSheet.Hyperlinks.Delete
Cells.Validation.Delete
Cells.FormatConditions.Delete

4. Вместо

Код
Sheets("!ККК").Cells(i, 14).Value = Sheets("12").Cells(2348, 12).Value
Sheets("!ККК").Cells(i, 27).Value = Sheets("12").Cells(2346, 14).Value
Sheets("!ККК").Cells(i, 28).Value = Sheets("12").Cells(2341, 11).Value
Sheets("!ККК").Cells(i, 29).Value = Sheets("12").Cells(2343, 12).Value
Sheets("!ККК").Cells(i, 30).Value = Sheets("12").Cells(2344, 12).Value
Sheets("!ККК").Cells(i, 31).Value = Sheets("12").Cells(2345, 12).Value
Sheets("!ККК").Cells(i, 32).Value = Sheets("12").Cells(2346, 12).Value
Sheets("!ККК").Cells(i, 33).Value = Sheets("12").Cells(2347, 12).Value
Sheets("!ККК").Cells(i, 34).Value = Sheets("12").Cells(2348, 12).Value
лучше так

Код
Set shККК = Sheets("!ККК")
Set sh12 = Sheets("12")

k = 0
rc = Array(2348, 12, 2346, 14, 2341, 11, 2343, 12, 2344, 12, 2345, 12, 2346, 12, 2347, 12, 2348, 12)

shККК.Cells(i, 14).Value = sh12.Cells(rc(0), rc(1)).Value

For j = 27 To 34
    k = k + 2
    shККК.Cells(i, j).Value = sh12.Cells(rc(k), rc(k + 1)).Value
Next
5. ".Activate/.Select" (Workbooks("2.xlsm") / Sheets("!ККК"))
".Activate / .Select" необходимо удалить из этого кода.
6. Какие именно действия, операции с файлом (ами) вы хотите выполнить ?
Автофильтр VBA - нет значений указанных по фильтру
 
Цитата
spa написал:
как бы ему сказать, что если нет значения иди вот сюда
??? ... : / ... ???

Код
    On Error Resume Next
        
        With ActiveSheet.Range("H2")
            .AutoFilter Field:=2, Criteria1:="=1", Operator:=xlOr, Criteria2:="=2"
        End With
        
    On Error GoTo 0
Проблема с запихиванием данных в массив
 
Цитата
nor написал:
при каждом прогоне макроса постоянно разный результат, то 4000 строк будет, то 69к, то 200к.
Проблема в максимальном объеме памяти на вашем компьютере и в системе (32-бит/64-бит).
Например, для 2 GB RAM (win 32-бит, office 32-бит) вы можете создать массив из 831590 строк x 40 столбцов (например у меня, но на разных компьютерах будет по-разному).
Если в памяти запущены другие процессы (в фоновом режиме) или память не была освобождена после других действий, у вас соответственно меньше места для таблицы в vba.

Цитата
nor написал:
Может кто подскажет как запихнуть ?
Это зависит от того, что вы фактически хотите делать с этими данными.
Вам может потребоваться использовать sql в vba или например PQ, или разделить данные на блоки и выполнить действия с отдельными блоками данных.
Кто знает, какие действия вы там выполняете над этими данными ?
Разделение таблицы в разные книги - можно ли оптимизировать?
 
После упорядочения (например, как показано ниже) вашего кода, время выполнения (для меня) составляет 41 с/120 файлов (0,34 с/1 файл)

Код
Option Explicit

Sub splitti_fitti()
    
    Dim StartTime As Single
    StartTime = Timer
    
    Dim Itm As Long, vCol As Long ', MyCount As Long
    Dim savepath As String ', path_f As String
    Dim ws As Worksheet
    Dim MyArr
    
    vCol = 1
    With ThisWorkbook
        'path_f = .Path
        savepath = .Path & "\To Send"
        Set ws = .Sheets("main")
    End With
    'savepath = path_f & "\To Send"
    
    If Dir(savepath, vbDirectory) = "" Then MkDir savepath
    
    With Application
        .ScreenUpdating = False: .EnableEvents = False
        .Calculation = xlManual: .DisplayAlerts = False
    End With
    ActiveWindow.View = xlNormalView
    
    With ws
        .Range("A1:A" & .Cells(.Rows.Count, vCol).End(xlUp).Row).AdvancedFilter _
                    Action:=xlFilterCopy, CopyToRange:=.Range("EE1"), Unique:=True
        .Range("EE1").CurrentRegion.Sort Key1:=.Range("EE2"), Order1:=xlAscending, Header:=xlYes
        MyArr = Application.Transpose(.Range("EE2:EE" & .Cells(.Rows.Count, "EE").End(xlUp).Row).Value)
        .Range("EE1").CurrentRegion.Clear
        '.Range("A1").CurrentRegion.AutoFilter
    End With
    
    For Itm = 1 To UBound(MyArr)
        Workbooks.Add
        
        With ws.Range("A1").CurrentRegion
            .AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
            .SpecialCells(xlVisible).Copy
        End With
        
        With ActiveWorkbook
            With ActiveSheet
                With .Range("A1")
                    .PasteSpecial xlPasteAll
                    Application.CutCopyMode = False
                    .Select
                End With
                .Rows("1:4").Insert Shift:=xlShiftDown
                With .Range("C1")
                    .Value = "Additional field:"
                    .Interior.ColorIndex = 6
                End With
                .Columns("A:G").AutoFit
                'MyCount = MyCount + .Range("A" & .Rows.Count).End(xlUp).Row - 5 '?
            End With
            .SaveAs savepath & ("\" & MyArr(Itm) & ".xlsb"), 50
            .Close False
        End With
    Next
    
    ws.AutoFilterMode = False
    Set ws = Nothing
    
    With Application
        .DisplayAlerts = True: .Calculation = xlAutomatic
        .EnableEvents = True: .ScreenUpdating = True
    End With
    
    Debug.Print Round(Timer - StartTime, 3) & " Secs for processing"
    
End Sub
CSV файл открывается в excel, сразу разделяя поля
 
Цитата
MSLOleg написал:
... csv файл, с разделителем |, но в данном файле есть строки, которые содержат знак ;
...
В тексте есть числа с .  Excel числа переводит в дату ( Если открывать таким методом
Если ваш "csv" (название например: "MSLOleg_csv.csv", путь к файлу csv: "C:\Temp\") выглядит так, как показано ниже:
Код
Header1|Header2|Header3|Header4|Header5
abcdefg|2019/1/12|458.89|-2.98|00000
bcadgfe;2021/1/15|-555.555;666.666|00001
lmkruzx|2021/1/9;777.777;444.444|00002
вы можете открыть его с помощью этого макроса:
Код
Sub fikoo_mikoo()
    Const strPth = "C:\Temp\"
    Const fle = "MSLOleg_csv.csv"
    
    Workbooks.OpenText Filename:=strPth & fle, Origin:=65001, StartRow:=1, DataType:=xlDelimited, _
                       TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Semicolon:=True, _
                       Other:=True, OtherChar:="|", _
                       FieldInfo:=Array(Array(1, 2), Array(2, 5), Array(3, 1), Array(4, 1), Array(5, 1)), _
                       DecimalSeparator:=".", TrailingMinusNumbers:=True
    ActiveSheet.Range("A1").CurrentRegion.EntireColumn.AutoFit
End Sub
Изменено: ocet p - 16.01.2021 04:59:12
При работе с Inputbox ошибка: Run-time error `1004`: Method 'Range' of object '_Global' failed
 
Цитата
Xalid Zalov написал:
такая проблема
Код
HT = InputBox("Input temperature:")

"HТ" у вас, это не число, а текст, и он всегда будет отличаться от числа.
"InputBox" должен быть в самом начале макроса, чтобы вы не выполняли ненужные действия, когда не введите температуру => "Cancel" или пустой текст.
"HT" должен быть типом "вариант" ( "As Variant" - желательно).
После ввода "HT" проверьте, является ли это числом, и преобразуйте его в тип "Double" (CDbl).
В случае успеха у вас есть число для сравнения в цикле, в противном случае вы должны обработать ошибку.

Заголовки "Дата" и "Температура" введите вне цикла.

Вместо:
Код
= Selection.Cells(i, 3) & "." & Selection.Cells(i, 2) & "." & Selection.Cells(i, 1)
напишите:
Код
DateSerial(Cells(i, "A").Value, Cells(i, "B").Value, Cells(i, "C").Value)
и отформатируйте диапазон дат соответствующим образом:
Код
.NumberFormat = "dd/mm/yyyy"

Не используйте слово "Reset" в названиях процедур, функций и переменных, констант - это внутреннее имя vba:

"Reset Statement - Closes all disk files opened using the Open statement"
Изменено: ocet p - 02.01.2021 21:09:05
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 15 След.
Наверх