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

Страницы: 1
Отловить ошибку в массиве, полученом из данных листа
 
Добрый день. Переношу таблицу с листа Excel в массив. В одной ячейке в excel есть ошибка #Имя? В массив эта ячейка переносится в виде Error 2029. В макросе надо проверить массив на пустые ячейки, т.е.
Код
If b(i,5)<>"" then
действие
End if
На ячейке с ошибкой Error 2029 макрос выдает ошибку Type mismatch на строке If b(i,5)<>"" then. Как проверить пустую ячейку или ошибку в массиве?
Мне нужно что-то вроде
Код
If b(i,5) <>"" and iserror b(i,5) =false then
Изменено: Hellmaster - 13 Мар 2020 13:43:39
Оставить строки с последними 13 датами
 
Добрый день. Имеется таблица, в столбце есть даты, допустим с 2019 года по сегодня (файл обновляется каждый день кроме праздников и выходных и каждый день добавляются строки с сегодняшней датой). Задача такая- нужно оставить строки с последними 13 датами от последней даты в файле, т.е. не просто date()-13 и не workday(date,-13), нужны именно уникальные 13 дат, которые есть в файле. Пример во вложении.
Запись CSV в массив. Какой разделитель строк?
 
Добрый день. Нашел в интернете решение по переносу csv в массив, но не пойму, какой разделитель строк в этом файле. В массив все заносится в 1 столбец. Код ниже, файл во вложении. Какой должен быть разделитель строк в этом csv файле?
Код
Sub mass()
fldr = "C:\"
s = "testdata-1000.csv"

b = TextFile2Array(, fldr, , s)
End sub
____________________________
Function TextFile2Array(Optional ByVal Title As String = "Выберите файл для обработки", _
                        Optional ByVal InitialPath As String = "c:\", _
                        Optional ByVal FilterDescription As String = "Текстовые файлы", _
                        Optional ByVal FilterExtention As String = "*.*", _
                        Optional ByVal ColumnsSeparator$ = ";", _
                        Optional ByVal RowsSeparator$ = "?") As Variant 'какой должен быть разделитель строк?

    On Error Resume Next

    With Application.FileDialog(msoFileDialogOpen)    ' диалоговое окно выбора файла CSV
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        filename$ = .SelectedItems(1)
    End With
    Set FSO = CreateObject("scripting.filesystemobject")    ' читаем текст из выбранного файла
    Set ts = FSO.OpenTextFile(filename$, 1, True): txt$ = ts.ReadAll: ts.Close
    Set ts = Nothing: Set FSO = Nothing
    txt = Trim(txt): Err.Clear    ' разделяем текст на строки и столбцы
    If txt Like "*" & RowsSeparator$ Then txt = Left(txt, Len(txt) - Len(RowsSeparator$))
    tmpArr1 = Split(txt, RowsSeparator$): RowsCount = UBound(tmpArr1) + 1
    ColumnsCount = UBound(Split(tmpArr1(0), ColumnsSeparator$)) + 1
    If Err.Number > 0 Then MsgBox "Строка не может быть разбита на двумерный массив", vbCritical: End
    ReDim arr(1 To RowsCount, 1 To ColumnsCount)
    For i = LBound(tmpArr1) To UBound(tmpArr1)
        tmpArr2 = Split(Trim(tmpArr1(i)), ColumnsSeparator$)
        For j = 1 To UBound(tmpArr2) + 1
            arr(i + 1, j) = tmpArr2(j - 1)
        Next j
    Next i
    TextFile2Array = arr    ' возвращаем результат в виде двумерного массива
End Function
Изменено: Hellmaster - 31 Янв 2020 11:54:35
Замена(ускорение) с помощью VBA формулы ВПР
 
Добрый день. Есть 2 файла с 300 000+ строк и 30+ столбцов. Из одного файла в другой надо заВПРить более 15 столбцов по 1 столбцу с ключом. Есть макрос, в котором прописаны именно ВПР типа
Код
Set x = Workbooks(xFile).Worksheets(xsheet).Rows(1).find("Поставщик", , xlFormulas, xlWhole)
   x1 = x.Column
 Cells(2, x1).FormulaR1C1 = "=VLOOKUP(C1,'[" & "Расчет_общий.xlsb" & "]" & xsheets & "'!C1:C8,8,0)" 
...
Application.Calculation = xlCalculationManual
Range("H2:S2").AutoFill Destination:=Range("H2:S" & xlastrow)
Application.Calculation = xlCalculationAutomatic
Range("H2:S" & xlastrow).Value = Range("H2:S" & xlastrow).Value

Таким способом макрос работает около часа. При отключении автоматического пересчета формул и включением после протягивания формул, макрос работает около 40 минут. Пробовал делать это циклом типа

Код
For i=1 to lastrow  
For i1=1 to lastrow2   
If cells(i,1)=cells(i1,1) then   
cells(i,10)=cells(i1,18) and _   
cells(i,12)=cells(i1,22) and _   
....   
End if  
Next i1
Next i

Работает такой вариант намного дольше (примерно 90 минут). Пробовал через массивы, в которые я закидывал обе таблицы + цикл типа предыдущего. Работает такой вариант тоже дольше чем ВПР.

Подскажите, пожалуйста, вариант, который будет работать быстрее. Если возможно, то небольшой пример кода с пояснениями.

Вставка в excel из массива построчно
 
Добрый день.

Имеется двухмерный массив. По условию я нахожу строку в массиве и нужно добавить ее в Excel. Пока что я смог только добавлять каждую ячейку. Подскажите как вставить сразу полностью строку в Excel.
Код
For i = 0 to 1000
  If b(56,i)="DRINK" then
    Workbooks("test").worksheets("test").range(cells(lr,1),cells(lr,lc))= range(b(0,i),b(135,i)) 'что-то вроде этого мне нужно
  End if
Next
APPCRASH экселя при сочетании клавиш с ctrl и открытии списка макросов во вкладке Разработчик.
 
Добрый день. Эксель начал крашиться при сочетании клавиш с ctrl. При этом мышкой все эти действия произвести можно. Та же проблема вылетает при работе с макросами, т.е. запись макроса, открытие Visual Basic, при нажатии на кнопку Макросы. Все что могу приложить-это скриншот ошибки. В чем может быть проблема?
Проверка ячейки на содержание слэша "/". VBA
 
Добрый день. Имеется таблица, в 1 столбце которой написано "удалить" и "добавить". Нужно, чтобы макрос удалял строки, в которых последнее слово "добавить" или его производные вроде "доб" или "добав" и т.д. Написал небольшой макрос, но он не распознает слэш "/" и поэтому работает неправильно. Помогите, пожалуйста написать макрос правильно.
Код
Sub mal_da_udal()
Dim lr As Long

lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row

For a = lr To 2 Step -1
  If Cells(a, 1) Like "*доб*" Then
   If Not Cells(a, 1) Like "*доб*/" Then
     Rows(a).Delete
   End If
  End If
Next

End Sub
Насколько бесконечный массив VBA
 
Добрый день.

Где предел измерения массива? К примеру, прокрутит ли он 1 млрд строк?
Обращение к ячейкам Access в цикле VBA
 
Добрый день. Как обращаться к ячейке таблицы Access в цикле VBA? В Excel это cells(1,1), в массиве это a(0,0). Как мне сделать цикл по ячейкам Access с вычислениями? Допустим, в первом столбце под названием "Арт" будут артикулы в виде цифр от 1 до 10. Во втором столбце "Цена" будут суммы (все по 100 для примера). Мне нужно пройти циклом по всем строкам таблицы.
Код
Sub perebor()
Dim db As Database
Dim rs As Recordset
Dim lngRecordCount As Long

Set db = CurrentDb
Set rs = db.OpenRecordset("q_promoexcel", dbOpenDynaset)
If rs.RecordCount <> 0 Then
rs.MoveLast

lngRecordCount = rs.RecordCount
rs.MoveFirst

     For i = 4 To lngRecordCount
       If rs(i,1) = rs(i-1,1) then rs(i,3) = rs(i-1,2)+rs(i,2) 'как обратиться к этим ячейкам правильно?
     Next

        rs.Close
        db.Close

End Sub
не работают макросы на Mac и Office 365
 
Добрый день. Написал макросы на вин7, которые работают идеально, но на компбютерах с Mac и Office 365 выдает ошибку invalid procedure call or argument на строке названия макроса, т.е. Sub macros()
Если в офисе 365 я еще понимаю в чем может быть проблема, то почему на Mac вылетает ошибка на этой строке, я не понимаю. Тестировал на другом компьютере Mac, там все работало. Библиотеки на обоих Mac стоят одинаковые. В чем может быть проблема?
Вставить таблицу Access в массив вертикально
 
Добрый день. Есть макрос, который берет таблицу Access в массив, но проблема в том, что массив горизонтальный выходит. То есть, вместо 6 столбцов получается 6 строк. Функция Transpose не работает, выдает ошибку Out of memory. Как вставить данные в массив вертикально?
Код
Sub Access()
Dim s As String, fldr As String
Dim dbsNorthwind As Database
Dim rstEmployees As Recordset
Dim strMessage As String
Dim b As Variant

Set dbsNorthwind = OpenDatabase("C:\OP.accdb")
Set rstEmployees = dbsNorthwind.OpenRecordset("SELECT * FROM q_promoexcel")
    b = rstEmployees.GetRows(rstEmployees.RecordCount)
     b = TransposeArray(b)
End sub
_______________________________________________________________________________________

Function TransposeArray(ByVal arr As Variant) As Variant
    Dim tempArray As Variant
    ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
    For x = LBound(arr, 2) To UBound(arr, 2)
        For y = LBound(arr, 1) To UBound(arr, 1)
            tempArray(x, y) = arr(y, x)
        Next y
    Next x
    TransposeArray = tempArray
End Function

Изменено: Hellmaster - 10 Окт 2019 22:45:24
Занести таблицу Access в массив
 
Добрый день. Пытаюсь подключиться к базе Аксес, чтобы занести данные таблицы в массив и вытягивать информацию из массива. Столкнулся с отсутствием нужной библиотеки для подключения к Аксесу. Подскажите, есть ли способ получить данные в массив без подключения библиотеки?
Мой код:
Код
Sub access()
   Dim cn As Object, rs As Object
   Dim intColIndex As Integer
   Dim DBFullName As String
   Dim TargetRange As Range
    
    DBFullName = "C:\OP.accdb"
    Set TargetRange = Sheets("Лист1").Range("B2")
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft ActiveX Data Objects 6.1 Library; Data Source=" & DBFullName & ";"
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT * FROM q_promoexcel", cn, , , adCmdText
    For intColIndex = 0 To rs.Fields.Count - 1
    TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
    Next
    
     On Error Resume Next
     appAccess.Close
     Set appAccess = Nothing
     cn.Close
     Set cn = Nothing
End sub
Подсчет уникальных значений в столбце (текст) с помощью макроса
 
Добрый день.
Имеется столбец с названиями. Как при помощи макроса посчитать количество уникальных значений в столбце?
Пытался сделать циклом, но ничего не вышло. Неудавшийся цикл ниже, файл во вложении.
Код
Sub as()
Dim a As Long
Dim b As Long
Dim lastrowdata as long
Dim ch As Integer
lastrowdata= Cells(Rows.count, 1).End(xlUp).Row
ch = 0
For b = 2 To a
  For a = 2 To lastrowData
    If b <> a And Cells(a, 4) <> Cells(b, 4) Then ch = ch + 1
  Next
Next
Cells(lastrowData + 1, 4).Value = ch
End sub
отмена RefreshAll (обновление Excel из Access) перед сохранением файла VBA
 
Добрый день. Файлы Excel привязанs к базе Access. Макрос открывает файлы Excel из папки по очереди, открывшийся файл обновляет из базы Access, просчитывает и далее сохраняет и закрывает, открывает следующий файл в папке, делает то же самое.
После строки обновления таблицы, на строке сохранения файла вылезает сообщение, о том, что это действие может привести к отмене обновления. Если нажать ОК, то файл не закроется и сразу же открывается следующий с такой же проблемой. Если нажать ОТМЕНА, то файл сохранится, но не обновится. Строку с сохранением файла можно ставить в любое место после строки Activeworkbook.RefreshAll, окно из скриншота все равно будет появляться на строке сохранения. Подскажите, как избежать этого окна с выбором ОК и ОТМЕНА, чтобы обновление, сохранение, закрытие и открытие нового файла Excel работало?
Скриншот окна во вложении. Макрос ниже.
Код
Sub perebor()
Dim s As String, fldr As String
'fldr = "C:\путь к файлу"
s = Dir(fldr & "файл *.xlsm")
Do While s <> ""
    With Workbooks.Open(fldr & s)
    ActiveWorkbook.RefreshAll
        lr = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
        lc = Worksheets("Лист1").Cells(1, Columns.Count).End(xlToLeft).Column

        Range(Cells(2, 9), Cells(lr, 9)).Clear
        R_data = Worksheets("Лист1").Range(Worksheets("Лист1").Cells(1, 1), Worksheets("Лист1").Cells(lr, lc))
        вычисления
        Worksheets("Лист1").Cells.Delete
        Worksheets("Лист1").Range(Worksheets("Лист1").Cells(1, 1), Worksheets("Лист1").Cells(lr, lc)) = R_data
        ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(lr, lc)), , xlYes).Name = "Таблица2"
        ActiveWorkbook.Save  'на этой строке выдает окно из скриншота.
        ActiveWorkbook.Close
    End With
    s = Dir
Loop
End Sub
Изменено: Hellmaster - 7 Окт 2019 12:37:03
Появляются лишние символы в пути к файлу при поиске файла с последней датой в файле
 
Добрый день. Есть код, который проверяет названия файлов в папке (название файла "файл 02.02.2019.xlsb", "файл 04.04.2019.xlsb" и т.д.) и открывает файл с последней датой. После срабатывания функции, переменной назначается путь к файлу, но после последнего слэша появляются знаки "-$" и макрос не может открыть файл. То есть, путь к файлу выглядит как "C:\путь\-$файл 04.04.2019.xlsb". Раньше макрос открывал файл и не было такой проблемы. Подскажите, в чем может быть проблема?
Код
Sub poisk_file_perviy_svezest()
Dim wb As Workbook

СамыйСвежийФайл$ = LastFile$("С:\путь\", ".xlsb")
Set wb = Workbooks.Open(СамыйСвежийФайл$)
_________________________________________________________________________________________________
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        Application.StatusBar = "поиск в папке: " & FolderPath
 
        For Each fil In curfold.Files
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1
        If SearchDeep Then
            For Each sfol In curfold.SubFolders
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing
    End If
End Function
Изменено: Hellmaster - 4 Окт 2019 11:06:03
Просмотреть checkbox по условиям
 
Добрый день. Как написать цикл по checkbox в userform, чтобы он работал не для каждого(for each), а проходил каждый checkbox по очереди и выполнял действия с каждым по очереди? Мне нужно перебрать каждый чекбокс и вставить значения в ячейки из текстбокс1 и текстбокс2. Т.к. для каждого текстбокс несколько чекбоксов, то нужно для каждого чекбокса отдельная строка, куда вставлять данные.
Мой код ниже:
Код
Dim x
Dim lr As Long
lr = .Cells(1, 1).End(xlUp).Row + 1
  For each x in Me.Controls    'эту строку нужно изменить, чтобы цикл ходил по чекбоксам по очереди
    If TypeOf x Is MSForms.CheckBox Then
      If x = True Then
        .Cells(lr, 1).Value = frmKust1.Value
        .Cells(lr, 3) = rcNow1.Value
        .Cells(lr, 4).Value = rcTo1.Value
          If x = FlowSwitcherForm.cat_sh_1 Then Cells(lr, 2) = "S"
          If x = FlowSwitcherForm.cat_fr_1 Then Cells(lr, 2) = "F"
          If x = FlowSwitcherForm.cat_alc_1 = True Then Cells(lr, 2) = "A"
          If x = FlowSwitcherForm.cat_of_1 = True Then Cells(lr, 2) = "FV"
          If x = FlowSwitcherForm.cat_z_1 = True Then Cells(lr, 2) = "Fr"
          lr = lr + 1
      End If
    End If
  Next
Изменено: Hellmaster - 10 Сен 2019 18:10:44
Если заполнено несколько чекбоксов, то вывести значения заполненных в ячейку
 
Добрый день. Имеется юзерформ с 5 чекбоксами. В работе их может быть заполнено от 1 до 5. Задача в следующем:
Если есть заполненные чекбоксы, то как вывести их значение в ячейку? Мой код ниже:
Код
Public sub cb()
Dim cb As Integer
cb = 0
If FlowSwitcherForm.cat_fr_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_sh_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_alc_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_of_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_z_1 <> "" Then
    cb = cb + 1
End If
With Worksheets("Расчет")
fr = Range("A1").End(xlDown)
  If cb = 1 Then
    Cells(fr, 1) = FlowSwitcherForm.frmKust1 And Cells(fr, 3) = FlowSwitcherForm.rcNow1 And Cells(fr, 3) = FlowSwitcherForm.rcTo1 And Cells(fr, 2) = cb.Value
  End If
End With
Конкретно интересует, как вывести в Cells(fr,2)= значение заполненного чекбокса?
Задать переменную с частью названия файла
 
Добрый день. Мне нужно задать переменную, не имея полного названия файла. Допустим, файл называется "Stock_Report_04.09.2019", находится в папке "С:\". В макросе я выявляю самый поздний файл в папке и дальше мне нужно задать переменную для файла. Как мне задать переменную последней строки открывшегося файла?
Код
Sub poisk_file_perviy_svezest()
Dim lr As Long
Dim lr2 As Long

СамыйСвежийФайл$ = LastFile$("C:\", ".xlsb")
    Workbooks.Open СамыйСвежийФайл$
lr = Workbooks("stock_report*.xlsb").Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Workbooks("Книга2.xlsx").Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row

___________________________________________________________________________________________________________
Function LastFile$(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                   Optional ByVal SearchDeep As Long = 999)
   
    Dim FilenamesCollection As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
    Set FSO = Nothing: Application.StatusBar = False
    Dim maxFileDate As Double
    For Each file In FilenamesCollection
        currFileDate = FileDateTime(file)
        If currFileDate > maxFileDate Then LastFile$ = file: maxFileDate = currFileDate
    Next file
End Function
___________________________________________________________________________________________________________ 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        Application.StatusBar = "поиск в папке: " & FolderPath
 
        For Each fil In curfold.Files
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1
        If SearchDeep Then
            For Each sfol In curfold.SubFolders
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing
    End If
End Function
Изменено: Hellmaster - 5 Сен 2019 13:09:19
Зависает Excel при 3-м повторе макроса
 
Добрый день. Появилась проблема. Зависает Excel при повторе макроса. Значения не меняются, ничего не меняется в файлах, макрос просто повторяет одно и то же, но на третьем разе зависает полностью Excel. ctrl+pause не работает, окна не отвечают. Выйти можно только через диспетчер задач или нажав на крестик в углу окна Excel. Файла примера не прикладываю, макрос смысла нет выкладывать, ибо там более 5к строк. Макрос работает с UserForm (3 шт.), 2 файла. Есть место в макросе, которое я недавно менял (не знаю, зависал ли Excel до того, как я поменял). При выборе варианта в юзерформ он открывает файл из сетевого диска. Думаю, что проблема в этом. Если файл уже открыт, то появляется окно "Файл уже открыт. Повторное открытие приведет к потере выполненных изменений". Если нажать в этом окне на крестик, то макрос корректно закончит работу, но на третий раз зависает Excel полностью.
Код
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False

Dim nagruzName As String
nagruzName = Worksheets("Лист1").Cells(1, 5)
otvet = MsgBox("Имя книги: " & nagruzName & " ?", vbYesNo)

Dim fullname As String
Application.ScreenUpdating = False
fullname = "W:\" & nagruzName & ".xlsb"
Select Case otvet
    Case vbYes
    On Error Resume Next
           Workbooks.Open fullname
    Case vbNo
           nagruzName = InputBox("Введите имя книги")
             If nagruzName = "" Then
               Exit Sub
             End If
On Error Resume Next
fullname = "W:\" & nagruzName & ".xlsb"
           Workbooks.Open fullname
           Workbooks("Книга1.xlsm").Worksheets("Лист1").Cells(1, 5) = nagruzName
End Select

Может кто-то уже сталкивался с такой проблемой?
Изменено: Hellmaster - 4 Сен 2019 14:00:04
Ячейка на пересечении столбца и строки через find
 
Добрый день.
Есть таблица с данными. Нужно задать ячейке на лист2 значение на пересечении столбца "5" и строки "3" после строки "30". Мне нужно задать переменные как адреса строки и столбца. Помогите додумать. Макрос ниже, файл во вложении.
Код
Sub peresech()
Dim w As Range
Dim rng1 As Range
Dim rng2 As Range
With Worksheets("Лист1")
Set rng1 = Rows(1).Find(what:="5", LookIn:=xlValues, lookAt:=xlWhole)
Set w = Columns(1).Find(what:="30", LookIn:=xlValues, lookAt:=xlWhole)
Set rng2 = Columns(1).Find(what:="3", after:=w, LookIn:=xlValues, lookAt:=xlWhole)
End With
With Worksheets("Лист2")
ActiveCell.Value = Intersect(rng2, rng1)
End With
End Sub
Имеется ли ограничение по темам на форуме?
 
Добрый день.

Появилась задача. Нужно связать эксель с SQL и SAP. В связи с этим, хотелось бы узнать, разрешено ли правилами форума задавать вопросы не только по Excel, но и по SQL в Вопросы по Microsoft Excel?
Изменено: Hellmaster - 13 Авг 2019 17:04:27
Поиск ближайшей точки по координатам
 
Добрый день. Имеется таблица.  В таблице имеются названия, у каждого из которых есть 2 критерия, долгота и широта. Нужно найти ближайшую точку по координатам, учитывая 2 критерия. То есть, вставить в столбец "Название Итог" значение найденной строки из столбца "Название", если критерий1 и критерий2 у двух сравниваемых строк одинаковый. Пробовал найти ближайшие через ближайшие координаты (не расстояние, а именно цифровой формат), но способ не дал тех результатов, которых я ожидал. Помогите с макросом.  
задать for от первой видимой ячейки до последней видимой ячейки (фильтр)
 
Добрый день. Есть данные. в 1 столбце стоит фильтр. Не знаю как задать For m1 от первой видимой ячейки до последней видимой ячейки. Помогите разобраться, как это сделать.
Мой код сейчас выглядит вот так:
Код
lastrow = Sheets("лист1").Cells(Rows.Count, 1).End(xlUp).Row
u = True
  For m1 = 2 To lastrow
    If Cells(m1, 7).SpecialCells(xlCellTypeVisible) <> "" Then
    u = False
  Exit For
    End If
  Next m1
    If u = True Then
    ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Изменено: Hellmaster - 5 Авг 2019 18:07:38
Поиск ближайших значений больше и меньше VBA
 
Добрый день.

Есть таблица со списком чего-то (назовем n). У каждого n есть координаты долготы и широты и по 2 критерия. Нужно найти для каждого n ближайшие к его координатам координаты других n (1 больше и 1 меньше), учитывая 2 критерия (чтобы критерии n начального совпадали с критериями n искомого) и подставить в столбцы "Координаты1, Координаты2...." Данные из столбца "Наименование" от n, которые мы нашли по ближайшим координатам. Третий день сижу и не могу придумать как это сделать макросом. Подскажите советом или куском кода. Файл во вложении.
Удаление строки по значениям из массива, Удалить строки по совпадению со значениями из массива
 
Привет. Есть 2 листа. на 1 листе есть таблица со значениями, которые нужно почистить. На втором листе есть таблица со значениями, которые нужно искать в таблице на первом листе и удалять строку, если совпадение. Нужно искать частичное совпадение, т.к. на втором листе часть строки из первого листа.
Имеется макрос, но он не делает ничего, просто проходит циклы, но не удаляет строки. Не могу понять в чем проблема. Файл прикреплен.

Option Compare Text
Sub test()
Dim lastrowto As Long
Dim e As Long
Dim a As Long
Dim lastrowdel As Long
Set result = Workbooks("result CF.xlsm").Worksheets("result")
Set result1 = Workbooks("result CF.xlsm").Worksheets("лист1")
With result.Range("result")
lastrowto = result.Cells(1, 5).End(xlDown).Row
lastrowdel = result1.Cells(1, 8 ).End(xlDown).Row
   For e = lastrowto To 1 Step -1
       For a = 1 To lastrowdel
           If result.Cells(e, 7).Value Like result1.Cells(a, 8 ).Value Then result.Cells(e, 7).EntireRow.Delete
       Exit For
       Next a
   Next e
End With
End Sub
Изменено: Hellmaster - 23 Апр 2019 13:56:50
Изменение границ ячеек по образцу VBA, Нужно сделать границы по образцу
 
Привет. Вставляю в имеющуюся таблицу в конец данные. Нужно протянуть формат границ от последней ячейки изначальной таблицы до конца новой таблицы.
Имеется такой код:    
Код
    lastrow = Cells(3, 5).End(xlDown).Row + 1
    result.Range("result").SpecialCells(xlCellTypeVisible).Copy
    finalWB.Cells(lastrow, 1).PasteSpecial Paste:=xlPasteValues
    lastRowLast = Cells(3, 5).End(xlDown).Row
    finalWB.Range("M" & lastrow - 1 & ":AA" & lastrow - 1).AutoFill Destination:=finalWB.Range("M" & lastrow - 1 & ":AA" & lastRowLast), Type:=xlFillDefault
    finalWB.Range("B" & lastrow & ":L" & lastRowLast).Borders.LineStyle = finalWB.Range("B" & lastrow - 1).Borders.LineStyle

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

Selection.AutoFilter Field:=3, Criteria1:="<" & Format(Range("r1"), "#"), Operator:=xlAnd
       result.Range("r1").copy
       .Range("result[Срок оплаты]").SpecialCells(xlCellTypeVisible).PasteSpecial Paste:=xlPasteValues
       On Error Resume Next
       result.ShowAllData
Проблема в том, что он вставляет не с первой видимой ячейки, а со второй(не считая заголовка) и добавляет в конце таблицы еще 1 строку, в которую вставляет значение ячейки r1
Макрос для преобразования в даты текстовых значений ячеек, не возможно изменить формат с помощью VBA
 
Привет. Из базы делаю выгрузку в xlsx формате. Там есть данные, которые мне нужно перевести в формат даты и дальше с ними работать. Проблема в том, что форматы не меняются. Можно изменить формат руками, если нажать F2+enter, если заменить точку на точку cntrl+f, если перевести файл в csv и подобные способы.
НО с помощью VBA ни один из способов не работает. Формат остается изначальным и не могу сделать, допустим, фильтр по дате. Подскажите как поменять формат данных на дату. Файл в приложении.
Страницы: 1
Наверх