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

Страницы: 1
Получить номер последней строки заданного листа из другой книги, Workbooks.Open
 
Здравствуйте Уважаемые специалисты,

Помогите с кодом.
Как получить номер последней строки заданного листа в другой книге?

Код
Sub LastRowCheck()
    
    Dim File As Object
    Set File = Application.FileDialog(msoFileDialogFilePicker)
    With File
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls*"
        If .Show <> -1 Then Exit Sub
        [A1] = .SelectedItems(1)
    End With
    
    Dim P As String: P = [A1]
    Dim WS As Object: WS = [A2]
    Set WS = ActiveWorkbook.Worksheet.Name
    
    Application.ScreenUpdating = False
    Workbooks.Open P
    [A3] = WS.Cells(Rows.Count, 4).End(xlUp).Row 'Здесь не работает...
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
    
End Sub
Макрос для Суммеслимн в памяти, Суммеслимн из другого листа
 
Здравствуйте Все,

Есть код Суммеслимн, но он работает только для одного листа, т.е. и диапазон суммирование и условие находятся на одном листе.

Как, сделать, чтобы суммировал диапазон из другого листа?

Вот код, который нужно исправить.

Файл с кодом в приложении.

Код
Sub SIMIFSINARRAY2() 
Dim SH1 As Worksheet, SH2 As Worksheet, I1 As Variant, I2 As Variant, ARR As Variant, R1 As Long, R2 As Long
Dim I As Long, J As Long, pCount As Long, D As Object

  Set SH1 = Sheets("22")
  R1 = SH1.Range("A" & Cells.Rows.Count).End(xlUp).Row
  I1 = SH1.Range("A2:J" & R1).Value
  
  Set SH2 = Sheets("33")
  R2 = SH2.Range("H" & Cells.Rows.Count).End(xlUp).Row
  I2 = SH2.Range("H2:J" & R2).Value
  
  
  ReDim ARR(1 To UBound(I1, 1), 1 To 1)
  ReDim ARR(1 To UBound(I2, 1), 1 To 1)
  Set D = CreateObject("Scripting.Dictionary")

  For I = 1 To R2 - 1
    If Not D.Exists(UCase(I2(I, 8 & I2(I, 9))) Then
        For J = 1 To R1 - 1
            If UCase(I2(I, 8) = UCase(I1(J, 1)) And _
                   UCase(I2(I, 9)) = UCase(I1(J, 2)) Then
                pCount = pCount + I1(J, 3)
            End If
        Next J
        D(UCase(I2(I, 8 & I2(I, 9))) = pCount
        ARR(I, 1) = pCount: pCount = 0
    Else
        ARR(I, 1) = D(UCase(I2(I, 8 & SH2(I, 9)))
    End If
  Next
  SH2.Range("J2").Resize(UBound(ARR, 1), 1).Value = ARR
End Sub
Оптимизация макроса(ускорение) по удалению лишних символом
 
Здравствуйте друзья,

Следующий макрос для удаления символом кроме цифр и букв выполняется за 10 сек. на 100 тыс. строках. Хочу переделать в массивный код. Не получается. Помогите исправить. Файл приложен.
Код
Sub CleanNow()
Dim T As Double: T = Now
FASTBEGIN 'отключаем свойства для быстродействия

    Dim RNG As Range
    Dim LC As Long: LC = Cells(Rows.Count, "D").End(xlUp).Row
    For Each RNG In Range("D1:E" & LC).Cells
        RNG.Value = AlphaNumeric(RNG.Value)
    Next RNG

FASTEND 'включаем свойства
MsgBox Now - T
End Sub

Public Function AlphaNumeric(str As String) As String
    Dim I As Long
    For I = 1 To Len(str)
        If InStr(1, "0123456789АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(str, I, 1)) Then AlphaNumeric = AlphaNumeric & Mid(str, I, 1)
    Next
End Function

Попробовал так:  
Код
Dim DATA As Variant, LC As Long, R As Long, C As Long
    With ActiveSheet
        LC = .Cells(.Rows.Count, "D").End(xlUp).Row
        DATA = .Range("D1:E" & LC).Value
        For R = LBound(DATA, 1) To UBound(DATA, 1)
        For C = LBound(DATA, 2) To UBound(DATA, 2)
                DATA(R, C) = AlphaNumeric(DATA(R, C))
        Next C
        Next R
        .Range("D1:E" & LC).Value = DATA
    End With
Изменено: Sanja - 31.10.2024 11:02:05 (Изменил название темы)
Замена английских букв на русские, Скорость выполнения макроса
 
Здравствуйте уважаемые специалисты,

Есть код для замены английских букв на похожие русские, но на больших данных макрос выполняется 25 сек. Хотелось бы быстрый вариант макроса. Буду признателен если сможете помочь.
Код
Sub ReplaceMe()
Dim T As Double: T = Now

On Error Resume Next
With Sheets("1")
    Dim LC As Long: LC = .Cells(Rows.Count, "D").End(xlUp).Row
    Dim RNG As Range
    For Each RNG In .Range("D1:E" & LC)

    If InStr(1, RNG, "A") > 0 Then RNG.Value = Replace(RNG, "A", "А")
    If InStr(1, RNG, "B") > 0 Then RNG.Value = Replace(RNG, "B", "В")
    If InStr(1, RNG, "E") > 0 Then RNG.Value = Replace(RNG, "E", "Е")
    If InStr(1, RNG, "K") > 0 Then RNG.Value = Replace(RNG, "K", "К")
    If InStr(1, RNG, "M") > 0 Then RNG.Value = Replace(RNG, "M", "М")
    If InStr(1, RNG, "H") > 0 Then RNG.Value = Replace(RNG, "H", "Н")
    If InStr(1, RNG, "O") > 0 Then RNG.Value = Replace(RNG, "O", "О")
    If InStr(1, RNG, "P") > 0 Then RNG.Value = Replace(RNG, "P", "Р")
    If InStr(1, RNG, "C") > 0 Then RNG.Value = Replace(RNG, "C", "С")
    If InStr(1, RNG, "T") > 0 Then RNG.Value = Replace(RNG, "T", "Т")
    Next RNG
End With

MsgBox Now - T
End Sub
Поиск часть текста и полное совпадение, Частичное и полное совпадение значений
 
Здравствуйте Уважаемые,

Нужна помощь. Есть код и в нём идёт поиск значений в 5ти столбцах, если часть текста найдена в списке.
в 5м столбце нужно производит точное совпадение

If InStr(1, Left(aListDB(I, 2), 2), aBaseDB(N, 5)) > 0 Then 'Здесь нужно точное совпадение

Помогите исправить код, пожалуйста.

Код
Sub PUTPRICECATPART()
    Dim aBaseDB(), aListDB(), aRes()
    Dim lRw As Long, I As Long, N As Long
    
    With Sheets("КАТАЛОГ")
        lRw = .Cells(.Rows.Count, 1).End(xlUp).Row 'последняя строка в столбце А
        aBaseDB = .Range("A1:G" & lRw).Value 'берём в массив все данные с листа, включая цену
    End With
    With Sheets("РЕСУРС")
        lRw = .Cells(.Rows.Count, 3).End(xlUp).Row    'последняя строка в столбце C
        aListDB = .Range("C5:N" & lRw).Value  'берём в массив все данные с листа
        ReDim aRes(1 To UBound(aListDB), 11 To 12)
        lRw = UBound(aBaseDB)
    End With
    'ищем совпадение 4 столбцов в Наименовании
    For I = 1 To UBound(aListDB)
    For N = 1 To lRw
        aRes(I, 11) = aListDB(I, 11)
        aRes(I, 12) = aListDB(I, 12)
            If InStr(1, aListDB(I, 1), aBaseDB(N, 1)) > 0 Then
            If InStr(1, aListDB(I, 1), aBaseDB(N, 2)) > 0 Then
            If InStr(1, aListDB(I, 1), aBaseDB(N, 3)) > 0 Then
            If InStr(1, aListDB(I, 1), aBaseDB(N, 4)) > 0 Then
            If InStr(1, Left(aListDB(I, 2), 2), aBaseDB(N, 5)) > 0 Then 'Здесь нужно точное совпадение
                aRes(I, 11) = aBaseDB(N, 6)
                aRes(I, 12) = aBaseDB(N, 7)
                Exit For
            End If
            End If
            End If
            End If
            End If
        Next N
    Next I
    Sheets("РЕСУРС").Range("M5").Resize(UBound(aRes), 2).Value = aRes
End Sub

Run-time error '5': Ошибка, Неправильный вызов процедуры
 
Добрый день!

Следующий макрос работал нормально, но перестал работать и выдаёт ошибку Run-time error '5. Работал с другими макросами в этом файле, а этот макрос не трогал, но он перестал работать. На старых копиях файла тоже не работает, и после нажатия Debug открывается последний файл и выделяет строку с ошибкой. На другом компьютере также не работает.

Если выбрать один файл, жёлтым выделяет вторую строку (А2), если два файла то третий.

Помогите с решением. Или дайте ссылку к теме.

Скрытый текст
Изменено: Шерзод Маткаримов - 24.01.2024 12:35:15
ПОИСК И ПОДСТАНОВКА, НУЖЕН БЫСТРЫЙ ВАРИАНТ ПОДСТАНОВКИ
 
Здравствуйте уважаемые,

Существует Каталог, откуда нужно получить значения 2х столбцов на другой лист если имеются соответствующие критериям строки.
Макрос есть, но если строк в Каталоге или в Списке куда переносятся данные, много, то макрос работает медленно.
Нужно улучшить этот макрос, или придумать другой вариант чтобы задача выполнялась мгновенно. Строк в Каталоге будет примерно 50 000-60 000, а в Списке может доходит до 1 000 строк.

Файл с примером и работающим макрос прилагаю.
При совпадении наименования получить его цену
 

Здравствуйте,

Нужен код для поиска цен из базы и если есть совпадения получить значение из столбца ЦЕНЫ в текущий лист.

Наименования для оценки в 2х столбцах (Имя и Ед.Из), а наименования в Базе, откуда нужно получить ЦЕНЫ в 4х столбцах (Имя+Спецификация+Спецификация2+Ед. Из). Если Имя для оценки, имеет значения, указанные в 3х столбцах Базы цен (Имя+Спец.+Спец2), нужно получить Цену для этого наименования.

Файл с примером наименований и примерным макросом прилагаю.

С уважением

Копировать-Вставить непустые строки
 

Здравствуйте,

Нужен макрос для быстрого копирования данных без пустых строк.
Вариант (Фильтр непустых строк->Копировать/Вставить->Очистка фильтра) в таблице из 40 тыс. строк занимает 13-15 секунд.
Вариант RemoveDuplicates тоже не лучше первого.

На этом форуме увидел макрос от Hugo, для переноса уникальных значений
Но и этот вариант работает медленнее варианта с фильтром.
Макрос выполняется за 4-5 сек., если отдельно запускать, А если вызвать внутри другого макроса (CALL CopyRange) выполняется 25 сек.

Макрос:

Код
Sub CopyRange()Dim FR As Long, LR As Long, A(), i&, II&, X As Byte, tmp$With Sheets("Лист1")FR = Application.Match(1, Range("AV1:AV100000"), 0)LR = .Cells(Rows.Count, 42).End(xlUp).RowA = Range(Cells(FR, 40), Cells(LR, 48))End With   ReDim b(1 To UBound(A), 1 To 9)   With CreateObject("Scripting.Dictionary")       For i = 1 To UBound(A)           tmp = A(i, 9)    '9 Столбец ключ уникальных значений           If Not .Exists(tmp) Then               .Item(tmp) = vbNullString               II = II + 1               For X = 1 To 3: b(II, X) = A(i, X): Next     '1 To 3 Столбцы для переноса           End If       Next   End WithSheets("Лист2").Range("AF14").Resize(II, 3) = b   '3 Кол-во нужных столбцовEnd Sub

Используя словарь или другие методы, можно ли добиться результата в 1-2 секунд?

Буду рад любой помощи.
Спасибо.

Поиск и подстановка в массиве
 
Здравствуйте,
Нужен удобный код массива, который быстро может извлечь данные из таблицы, аналог Индекс/Поискпоз.
С массивными кодами ранее не работал. Хотелось бы, получить такой код от профессионала.
Задача:
1) Чтобы, искал и извлекал данные по двум и более критериям
2) В одном коде выполнить поиск и подстановку  для нескольких диапазонов.

Сейчас есть код, который ищет по одному условию, и я хотел сделать поиск по двум условиям, но не работает.
Вот код.
Код
Sub Test()
FastBegin
Dim S As Double
S = Now

Dim BinosozDB As Variant, BinoDB As Variant, Result As Variant, t As Variant, BinosozLR As String, BinoLR As String, i As Long, j As Long
Dim sl: Set sl = CreateObject("Scripting.Dictionary")

With Sheets("Database")
BinosozLR = .Cells(.Rows.Count, "AH").End(xlUp).Row
BinosozDB = .Range(.Cells(14, 2), .Cells(BinosozLR, 34))
End With

With Sheets("BINO")
BinoLR = .Cells(.Rows.Count, "C").End(xlUp).Row
BinoDB = .Range(.Cells(14, 1), .Cells(BinoLR, 6))
Result = .Range(.Cells(14, 7), .Cells(BinoLR, 7))

For i = 14 To BinosozLR
    sl(BinosozDB(i, 1) & BinosozDB(i, 3)) = BinosozDB(i, 32)
Next i

For j = 14 To BinoLR
    t = BinoDB(j, 1) & Left(BinoDB(j, 3), 250)
    If sl.Exists(t) Then
        Result(j, 1) = sl(t)
   End If
Next j

.Range(.Cells(14, 7), .Cells(BinoLR, 7)) = Result
End With

FastEnd
MSGBOX Now - S, 64
End Sub 

Вкратце, нужны примеры:
Как искать по одному условию.
Как искать по двум условиям
Как выполнить две задачи в одном макросе (вставил в столбец А, следующий код для столбца В)
И желательно с описаниями, чтобы я мог понять и применить в своих файлах.

И еще один момент. Код выше ищет и выводит последнее совпадение, если имеются дублирующиеся строки. Хотелось, бы чтобы выводил первый найденный результат.

Бюджет 500 руб.

С уважением.
Код массива по поиску и подстановке работает медленно, Ускорить работу макроса
 
Здравствуйте,

Сейчас на листе на 20 тыс. строках стоит нижеследующая формула, и работает она медленно. На пересчёт уходит примерно 20 сек.
Хотел, применить код для выполнения задачи в массиве и перенести результат на лист.
Но и этот код работает 22 сек.
С массивными кодами ранее не сталкивался. Как можно добиться нужного результата? Вроде массивный код должен работать очень быстро. И еще, результат, тоже не точный выводит. Может неправильно применил функцию Left()?


Формула
Код
Range("P14:P20000").Formula ="=IFERROR(INDEX(R14C12:R20000C12,MATCH(INDEX(R1C1:R20000C1,ROW())&LEFT(INDEX(R1C3:R20000C3,ROW()),250),R14C11:R20000C11,0)),"""")"

Код
Код
Sub Test()
FastBegin
Dim S As Double
S = Now

Dim From As Variant, Into As Variant, Result As Variant, LastRow1 As String, LastRow2 As String, i As Long, j As Long

LastRow1 = Cells(Rows.Count, "K").End(xlUp).Row
LastRow2 = Cells(Rows.Count, "C").End(xlUp).Row

From = Range(Cells(1, 11), Cells(LastRow1, 12))
Into = Range(Cells(1, 1), Cells(LastRow2, 3))
Result = Range(Cells(1, 20), Cells(LastRow2, 20))

For i = 1 To LastRow1
For j = 1 To LastRow2
    If From(i, 1) = Into(j, 1) & Left(Into(j, 3), 250) Then
        Result(j, 1) = From(i, 2)
        Exit For
     End If
 Next j
Next i

Range(Cells(1, 20), Cells(LastRow2, 20)).Value = Result

FastEnd
MSGBOX Now - S, 64 ' результат 22 секунды
End Sub
Изменено: Шерзод Маткаримов - 11.01.2021 00:12:02
Ввод формул с плюсом в числовом или процентном формате, Ввод формулы
 
Здравствуйте,

Есть столбец для ввода процентов, и обнаружилось что в процентном или в числовом формате если вводить формулу с плюсом, а именно целое число делённое на нецелое то выдаёт ошибку "Ошибка в формуле".
+50 / 250,50 Ошибка
+50 / 250 Работает
+50,5 / 80,5 Работает
+50,5 / 250 Работает

Целое/нецелое работает если вводить со знаком равенства или стоит Общий формат.

Как избежать этой ошибки? Важно, чтобы эта ошибка не выскакивала.
Может есть какой код для Private Sub Worksheet_Change(ByVal Target As Range)?

Спасибо.  
Изменено: Шерзод Маткаримов - 07.01.2021 15:41:00
Получение данных из другой закрытой или открытой книги, VBA Formula
 

Здравствуйте,

Необходимо получить данные из другой книги, независимо открыта или закрыта эта книга.

Следующий код переносит данные только из закрытой книги. И если книга открыта, нужно закрыть книгу, чтобы код работал.

Код
Sub Get_Value_From_Close_Book_Formula()
    Dim sPath As String, sFile As String, sShName As String
    sPath = "C:\Documents and Settings\" '"
    sFile = "Книга1.xls" '"
    sShName = "Лист1" '"
    Application.DisplayAlerts = 0
    With Range("A1:A100")
        .Formula = "='" & sPath & "[" & sFile & "]" & sShName & "'!" & "A1" '"
        '"A1" - указывается начальная ячейка диапазона, из которого необходимо получить значения
        .Value = .Value
    End With
    Application.DisplayAlerts = 1
End Sub

Можно ли переделать этот код, или другой вариант, чтобы получить из закрытой и открытой книги?

Спасибо.

Полный путь к закрытому файлу и листу, Формула
 
Здравствуйте,

Вопрос по следующему коду:
Код
Sub GetData()
On Error GoTo ERROR
    If Range("A1") = vbNullString Then Exit Sub
    Dim sFilePath As String, sShName As String
    sFilePath = Range("A1").Value2 'A1-Полный путь к файлу
    sShName = "ЛИСТ С ДАННЫМИ" 'Лист неизвестен
    Application.DisplayAlerts = 0
    With Range("A10:H100")
        .Formula = "='" & sFilePath & sShName & " '!" & "A1" '"
        .Value = .Value
    End With
    Application.DisplayAlerts = 1
ERROR: Range("A10:H100").ClearContents
End Sub
 

Как правильно написать строку формулы (.Formula = "='" & sFilePath & sShName & " '!" & "A1" '") ?

Сейчас, вставляется формула ='C:\Users\Администратор\Desktop\[Книга1.xlsbЛИСТ С ДАННЫМИ]Книга1'!A1. Если вместо ЛИСТ С ДАННЫМИ ничего не писать (sShName = "") то формула работает, НО в случае, если имя книги и имя листа одинаковы, то обращение идёт на лист с одинаковым именем.

Еще один вопрос. Не принципиально важный. Просто для информации. Если отменить окно для выбора листа, выдаёт ошибку и вставляются ссылки в рабочем диапазоне, и я применил, если ошибка Очистить рабочий диапазон. Можно ли без очистки диапазона, просто выйти из макроса?

Спасибо.

 

Изменено: Шерзод Маткаримов - 15.12.2020 07:35:40
Получение значений из любой книги, Диалоговое окно
 
Здравствуйте,

Мне нужен код для получения значений из любой другой закрытой или открытой книги.
Сейчас я пользуюсь следующим кодом.
Код
Sub GetPrice()
Range("A1:C10000") = "=IFERROR(IF('[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ ЛИСТ'!RC=0,"""",'[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ ЛИСТ'!RC),0)"
End sub

Проблема, в том что, если отменить диалоговое окно для выбора файла, код продолжает выполнятся и вставляется нули.
Необходимо, чтобы выполнение макроса остановилось (exit sub), если отменить диалоговое окно.

Хотел поэкспериментировать с Application.GetOpenFilename и FileDialog(msoFileDialogFilePicker) после чего появились ошибки.
При запуске выдаёт ошибку Method_Default of object 'Range' failed, а если указать Range("A1:C10000").FormulaR1C1 то ошибка Method 'FormulaR1C1' of object 'Range' failed. Или же формула вставляется, но связи не обновляются (не появляется окно для выбора листа).

Вообщем, нужно чтобы при запуске макроса, появилось окно откуда можно выбрать любой файл и любой лист и получить значения в текущую книгу. А при отмене окна, выйти из макроса.

Спасибо за внимание.
Получение данных из закрытой книги через Application.GetOpenFilename
 
Здравствуйте,

Это код работает
Код
Range("A1:C10000") = "=IFERROR(IF('[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ СПИСОК'!RC=0,"""",'[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ СПИСОК'!RC),0)"

А вот так, не работает.
Код
Dim x As Variant
x = Application.GetOpenFilename(, , "Выбор файла")
If x = False Then
Exit Sub
Else  
Range("A1:C10000") = "=IFERROR(IF('[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ СПИСОК'!RC=0,"""",'[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ СПИСОК'!RC),0)"
End if
В интернете не смог найти решение. Помогите.
Изменено: Шерзод Маткаримов - 08.12.2020 18:13:08
Получение данных из другой книги, Отмена окна для выбора файла
 
Добрый вечер,

Товарищи, помогите пожалуйста.

Необходимо перенести данные из закрытой книги.
Следующий код не работает. Что не так?
Код
Dim x As Variant
x = Application.GetOpenFilename(, , "Выбор файла")
If x = False Then
Exit Sub
Else

Range("A1:C10000") = "=IFERROR(IF('[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ СПИСОК'!RC=0,"""",'[ВЫБРАТЬ ФАЙЛ.xlsb]ВЫБРАТЬ СПИСОК'!RC),0)"

End if



Спасибо.




Изменено: Шерзод Маткаримов - 08.12.2020 08:16:34
Ввод чисел в Textbox в процентном формате.
 
Здравствуйте специалисты,
Возник вопрос. В сети не смог найти ответ.
Есть на форме 10 Textboxов для ввода чисел в формате процента.
Перехожу через Tab или Enter в другую ячейку и когда выхожу из ячейки число разделённое запятой (12,40%) округляется (12,00%).
Еще один вопрос, число нужно вводит только через точку, если через запятую то окргуляется. Можно ли вводить и с запятой и с точкой?
Вот код:
Код
Private Sub T3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
On Error GoTo Err
T3.Value = Format(Val(T3.Value) / 100, "Percent")
Err:
T3.Value = Replace(T3.Value, ".", ",")
End Sub
Макрос для загрузки файла по URL, Compile error: Variable no defined
 

Приветствую уважаемые,                                                                                                      

Возникла странная ситуацию со следующим кодом.

Код работает в одной книге, а в нужной мне книге не работает.

Я внёс некоторые изменения в файл (в таблицах и макросах) и теперь, когда запускаю макрос, выдаёт ошибку Compile error:  Variable no defined и выделяет oStream строке Set oStream = CreateObject("ADODB.Stream"). Проверил резервный файл до изменений, макрос работает. С чем это связано? Помогите, пожалуйста.

Код
Option Explicit
Sub DOWNLOADFILE()
    Dim myURL As String
    On Error GoTo DOWNLOADFILE_Error
    myURL = "МОЙ ВЭБ"
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "Username", "Password"
    WinHttpReq.send
    If WinHttpReq.STATUS = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile "C:\файл.exe", 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If
    MsgBox "ФАЙЛ ЗАГРУЖЕН В ДИСК 'C!"
    On Error GoTo 0
    Exit Sub
DOWNLOADFILE_Error:
  MsgBox "ПРОВЕРЬТЕ СОЕДИНЕНИЕ С ИНТЕРНЕТОМ"
End Sub
Изменено: Шерзод Маткаримов - 10.11.2020 16:32:11
Выделенные строки и Нужный столбец, Selection/Column
 
Здравствуйте Уважаемые,

Помогите Пожалуйста,
Следующий код работает, если выделить несколько строк, но если выбрать только одну строку то тормозить и выдает неверный результат.

Спасибо.
Код
Dim Rng As Range
Set Rng = Selection.SpecialCells(xlCellTypeVisible)
For Each rr In Rng.Rows
    If Range("A" & rr.Row).Value > 4 Then Range("A" & rr.Row).Value = 8
    If Range("A" & rr.Row).Value > 4 Then Range("A" & rr.Row & ":C" & rr.Row).Font.Color = RGB(0, 0, 255)
Next
ThisWorkbook.Path для Index/Match
 
Приветствую уважаемые,

Следующий код обращается к файлу на диске 'C.    
Код
Range("E5:E100") = "=IFERROR(INDEX('C:\[КАТАЛОГ.xlsb]КАТАЛОГ'!$C:$C,MATCH($C5,'C:\[КАТАЛОГ.xlsb]КАТАЛОГ'!$A:$A,0)),0)"

У некоторых пользователей может отсутствовать диск 'C, поэтому необходимо чтобы код обращался в свою папку (ThisWorkbook.Path) или в существующий системный диск.

Если из кода убрать 'C:\ то появляется окно, откуда можно выбрать файл, но хотелось бы без этого окна?

Такое возможно?

Спасибо.
Оптимизация макроса, Ускорение работы макроса
 
Приветствую знатоков макросов. Нужна помощь по оптимизации макроса.
Нижеследующий макрос выполняет задачу за 4 минут. Нужно сократит время работы макроса до минуты (желательно до нескольких секунд).
Код
Sub InputData()
FastBegin 'отключаем свойства для быстродействия'
ThisWorkbook.Unprotect

    Dim LastRow As Long
    With Sheets("ФОРМА 2")
    .Unprotect
    .Range("B13:G20000").MergeCells = False
    .Range("AB13:AG20000").Formula = .Range("AB13:AG13").Formula
    .Range("B14:G20000").Value = .Range("AB14:AG20000").Value
    .Range("AB14:AG20000").ClearContents
    .Range("E2").Value2 = "ДАТА"
    .Range("Y13:Y20000").Formula = .Range("Y13").Formula
    .Range("Y14:Y20000").Value = .Range("Y14:Y20000").Value
    .Range("Y14:Y20000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .Range("I:I").EntireColumn.Hidden = False
    .Shapes.Range(Array("Rectangle 6", "Rectangle 7", "Rectangle 12", "Rectangle 13", "Rectangle 14", "Rectangle 15")).Visible = msoTrue
    LastRow = .Cells(Rows.Count, "Y").End(xlUp).Row
    .Range("B14:X" & LastRow).Borders.Weight = xlHairline
    .Range("B14:X" & LastRow).Font.Name = "Arial Narrow"
    .Range("B14:X" & LastRow).VerticalAlignment = xlCenter
    .Range("B14:X" & LastRow).Font.Size = 10
    .Range("B14:X" & LastRow).Font.Color = RGB(0, 0, 0)
    .Range("B14:U" & LastRow).Font.Bold = False
    .Range("B14:X" & LastRow).Font.Italic = False
    .Range("B14:X" & LastRow).Font.Underline = xlUnderlineStyleNone
    .Range("B14:X" & LastRow).Interior.Pattern = xlNone
    .Range("B14:E" & LastRow).HorizontalAlignment = xlCenter
    .Range("D14:D" & LastRow).HorizontalAlignment = xlLeft
    .Range("F14:G" & LastRow).NumberFormat = "#,##0.000"
    .Range("F14:W" & LastRow).HorizontalAlignment = xlRight
    .Range("H14:I" & LastRow).NumberFormat = "#,##0"
    .Range("I13:W" & LastRow) = Range("I13:W13").Formula
    .Range("AA14:AG" & LastRow) = Range("AA12:AG12").Formula
    .Range("X14:X" & LastRow).Interior.Color = RGB(218, 238, 243)
    If CheckBox1.Value = True Then .Range("H13:H" & LastRow) = Range("H13").Formula
    
    Dim i As Long, r3 As Range, r4 As Range, r5 As Range, r6 As Range
    For i = 14 To 20000
    Set r3 = Range("Y" & i)
    Set r4 = Range("B" & i & ":U" & i)
    Set r5 = Range("D" & i)
    Set r6 = Range("H" & i & ":U" & i)
    If r3.Value = 1 Then r4.Interior.Color = vbYellow
    If r3.Value = 1 Then r4.Font.Size = 14
    If r3.Value = 1 Then r4.HorizontalAlignment = xlLeft
    If r3.Value < 3 Then r4.Font.Bold = True
    If r3.Value = 1 Then r4.WrapText = False
    If r3.Value = 3 Then r4.Font.Color = RGB(128, 0, 128)
    If r3.Value = 5 Then r4.Font.Color = RGB(0, 0, 128)
    If r3.Value = 1 Then r6.ClearContents
    Next i
    .Range("B14:H30000, T14:T30000, X14:X30000").Locked = False
    .Rows("14:20000").EntireRow.AutoFit
    End With

    Sheets("ИТОГ").Rows("2:47").Copy
    Range("Y" & Rows.Count).End(xlUp).Select
    Rows(ActiveCell.Row).Offset(1, 0).ACTIVATE
    ActiveSheet.Paste
    Range("Z13:Z20000").Formula = Range("Z13:Z13").Formula
    Range("Z14:AA20000").Value = Range("Z14:AA20000").Value
    If CheckBox1.Value = True Then Sheets("РЕСУРС").Visible = True
    Sheets("ФОРМА 3").Visible = True
    Sheets("ФОРМА 4").Visible = True
    Sheets("ФОРМА 2").Protect AllowFormattingCells:=True, AllowFiltering:=True
    ThisWorkbook.Protect
FastEnd 'включаем свойства'
End Sub
Формулы на листе очень простые и они не замедляют макрос. Цикл For i = 14 To 20000 который форматирует условные ячейки, замедляет макрос на 1 минуту. Без него макрос работает 3 минуты, но форматирование обязательно нужно.

Мне сказали, что не все специалисты охотно берутся за оптимизацию макросов, но я надеюсь кого-нибудь эта работа заинтересует.
Если кто-нибудь сможет выполнить этот заказ, могу отправить сам файл с макросом на почту.

С Уважением
Изменено: sherzodom - 06.04.2020 23:38:46
Страницы: 1
Loading...