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

Страницы: 1 2 След.
Скопировать все ссылки с сайта VBA
 
Добрый день!

Я не работала с сайтами, сейчас надо выгрузить все ссылки с сайта. Они содержаться в атрибуте href
Все что у меня получается это копировать с сайта.

Буду благодарна, если подскажете как скопировать ссылки.
Код
Sub Oem_Value()

    Dim post As Object
 Dim selectItems As Variant

    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "https://zunamiprotocol.medium.com/followers"
      
        While .readyState < 4: DoEvents: Wend

        For Each post In .Document.getElementsByName("eh ei bz ca cb cc cd ce cf bl ej ek cg el em")
            r = r + 1: Cells(r, 1) = post.innerText
        Next post
        .Quit
    End With

End Sub
Преобразование числа в текст
 
Добрый день! не могу понять как мне сделать, макрос копирует столбец и вставляет как значение, после удаляет символы, но вылезает ошибка Преобразовать в число, с зеленым уголочком и нужно вручную проводить.
Как макрос сделать, чтобы после копирования, сразу было значение.
В вручную все проходит хорошо, а макросом вылезает эта ошибка.
Код
 Range("A2:A8").Copy
   Worksheets("Лист1").Range("A2:A8").PasteSpecial Paste:=xlPasteValues
      
        
    Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="$", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Найти наибольшее значение в столбце между жирными шрифтами
 
Добрый день!
Простая вроде задача, не могу сообразить сейчас.
Надо найти наибольшее значение между жирными шрифтами и может как н выделить.
Думала про макрос, не не поняла как это обозначить в цикл.
По очереди в каждом диапазоне. Те сначала в строках 4,5, потом 7,8 и так далее
Распределение суммы по дням недели
 
Добрый день! столкнулась с проблемой такого характера. есть план продаж на месяц. но в определенные дни должны продавать не меньше 40 тыс, в другие не меньше 15 тыс. также есть факт который подставляется в план и в зависимости от этого дальнейший план пересчитывается, чтобы сумма месяца соответствовала плановой сумме продаж, которой надо придерживаться. так вот, проблема в пересчете, как прописать формулу чтобы пересчитывал по параметру не меньше 40000 в определенный день и не меньше 15 в другой день, а сумма месячного плана всегда соответствовала заданной цифре.
Скопировать данные со страницы explorer
 
Добрый день!
Буду очень благодарна, если подскажите как мне скопировать индекс почтовый в ексель.
Никак не получается у меня.

Заранее спасибо!
Код
Sub Индекс()

 Dim IE As Object
 Dim N As Integer
 
Dim lLastRow As Variant
lLastRow = ThisWorkbook.Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row

Set IE = CreateObject("InternetExplorer.Application")

   IE.Navigate "https://indexphone.ru"

    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.Document
  
     For N = 2 To Cells(Rows.Count, 2).End(xlUp).Row
     
     .GetElementsByName("search")(0).Value = Cells(N, 2).Value
    SendKeys ("{Enter}")

Sheets("Лист1").Cells(N, 4).Value = IE.Document.getElementsByClassName("post-search-list-postalcode")(0).innerText
  Application.Wait Time:=Now + TimeValue("0:00:10")

 Next
     End With
End Sub
Изменено: kleo90 - 04.12.2019 14:31:07
Фильтрация данных по списку по одному месяцу
 
Добрый день!
Может есть какой то  способ для фильтрации по месяцам данных. Мне нужно чтобы при выборе месяца мне выдавало только данные по этому месяцу и тп. Как например это делает фильтр в сводной таблицы.
Данные во вложении
Распределить данные из одной ячейки по столбцам
 
Добрый день!
Кто может подсказать как вытащить данные из ячейки, в одной ячейке много инфы, но нужны только фио паспорт и номер серия, те определенные данные.
Но в ячейке текст распределен непонятно и даже текст по столбцам не работает(
Если какие приемы чтобы распределить данные по ячейкам, если данные в таком формате.
Разбить текст из одной ячейки на несколько по условию
 
Добрый день!
Никак не могу найти решение как мне разбить текст из одной ячейки по условию.
Допустим у меня текст в одной ячейке:" ООО "СЭТЛ СИТИ" 196066 САНКТ-ПЕТЕРБУРГ ГОРОД ПРОСПЕКТ МОСКОВСКИЙ 212 ЛИТ.А , ОГРН: 1027804904379, Дата присвоения ОГРН: 17.12.2002, ИНН: 7810212380, КПП: 781001001, Генеральный Директор: Еременко Илья Анатольевич"

я хочу разделить отдельно в ячейки адрес, огрн, инн, кпп, только без слова ИНН и огрн, кпп

Заранее спасибо!
Копирование данных в цикле по условию
 
Добрый день! Я повышаю свои знания по работе с VBA)
Подскажите, у меня вот такой код, все делает как надо, НО копирует данные во вторую ячейку, и не копирует данные последней ячейки, те в интернете находит, а данные не копирует, и это именно последняя ячейка всегда((
В итоге мне нужно что находило значение из ячейка А1 и найденные данные копировал соответственно в ячейку В1
Но выходит так, что копирует данные найденные по значение А1 и вставляет в В2(( А надо чтобы в А1
И последние данные не копирует вообще.
Что я не так делаю в цикле
Код
Sub f()

 Dim IE As Object
 Dim N As Integer
 Dim sAnswer As String

' On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
   IE.Navigate "http://egrul.nalog.ru/index.html"
   
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.document
 
     For N = 1 To Cells(Rows.Count, 1).End(xlUp).Row
     
       .GetElementsByName("query")(0).Value = Cells(N, 1).Value
       .getElementById("btnSearch").Click

   Sheets("Лист1").Cells(N, 2).Value = IE.document.getElementById("resultContent").innerText
  
      
 Application.Wait Time:=Now + TimeValue("0:00:10")
 
 Next N
  
    End With

End Sub
Копировать данные с сайта с помощью VBA
 
Добрый Вечер! Возник еще один вопрос( как скопировать данные которые я нашла по поиску на сайте, те результат поиска(
По тому что я нашла на просторах интернета не подходит, одна последняя строчка никак не идет.
Код
Sub f()
 Dim IE As Object
' On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
   IE.Navigate "http://egrul.nalog.ru/index.html"
   
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.Document

        .GetElementsByName("query")(0).Value = Cells(0, 1).Value
       .GetElementById("btnSearch").Click

    Cells(0, 2).Value = IE.Document.getElementsByClassName("div.res-text")(0).innerText
 
'ЗДЕСЬ НИКАК НЕ ВЫХОДИТ НИЧЕГО((
    End With
End Sub
Изменено: kleo90 - 15.03.2019 10:48:16
Поиск данных в интернете через VBA
 
Добрый день!
Раньше не делала таких макросов, не понимаю как его заставить нажимать кнопку для поиска данных которые вводятся в строку поиска. Помогите плиз. Что нужно использовать, чтобы найти данные из строки поиска(((
Мне постоянно выводит ошибку
Код
Sub f()

 Dim IE As Object
 On Error Resume Next
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.Navigate "http://egrul.nalog.ru/index.html"
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
    With IE.Document
        .GetElementsByName("query")(0).Value = "7816676808"
       .GetElementsByName("submit")(0).Click

    End With

End Sub
Копировать диапазон от залитой строки до следующей залитой
 
Добрый день, никак не могу понять как мне задать диапазон,
мне нужно найти выделенное заливкой, и далее скопировать это строку полностью,то что за ней до первой залитой строки на соседний лист
Как задать условие для диапазона
Изменено: kleo90 - 24.10.2017 16:20:57
Выбор диапазона по заливке
 
Подскажите как мне выбрать диапазон, от одной залитой ячейки до другой такого же цвета залитой ячейки, макросом. как задать данный диапазон.
Изменено: kleo90 - 24.10.2017 09:27:54
Выравнивание объектов ексель
 
Нужна очень помощь, макрос есть, он вставляет на лист огромное количество картинок, причем друг на друга, далее мне их надо расставить по порядку чтобы можно было просматривать, например по 4 в ряду,рядом друг с другом, и далее вниз по количеству картинок.
Ранее мне дали макрос, но он расставляет просто в линию все объекты.
Как мне сделать чтобы все было красиво.

Вот макрос по расстановке в линию.
Код
Sub test()
    Dim sh As Shape
    Dim j As Double

    j = 1
    For Each sh In ActiveSheet.Shapes
        sh.Left = j
        j = j + sh.Width
    Next sh
End Sub
Расстановка картинок в ексель
 
Всем добрый вечер!
Помогите с задачей,. У меня есть макрос который автоматически вставляет 50 картинок, но вставляет их все друг на друга, как можно автоматически их расставить рядом друг с другом например. Чтобы в ручную их не растаскивать. Если какие способы.
Заранее огромное спасибо, выручите)
Копирование графиков на новый лист
 
Добрый день!
У меня есть макрос который создает последовательно куча графиков, если возможно копировать эти графики на новый лист, но не на друг друга, а картинками последовательно, чтобы потом можно было смотреть все
Код
Sub график()
Dim i As Long
Dim name As String
For i = 2 To 50

Sheets("Ëèñò7").Select    
 ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
    ActiveChart.SetSourceData Source:=Range(Cells(i, 1), Cells(i, 4))
    ActiveChart.FullSeriesCollection(1).XValues = "=Ëèñò2!$B$1:$D$1"
   ActiveChart.FullSeriesCollection(1).Values = Range(Cells(i, 2), Cells(i, 4))
    ActiveChart.SetSourceData Source:=Range(Cells(i, 1), Cells(i, 4))
    ActiveChart.FullSeriesCollection(1).XValues = "=Ëèñò7!$B$1:$D$1"
     ActiveChart.FullSeriesCollection(1).Select
    ActiveChart.FullSeriesCollection(1).Trendlines.Add
    ActiveChart.FullSeriesCollection(1).Trendlines(1).Select
    Selection.Type = xlLogarithmic
    
     If MsgBox("Продолжить?", vbYesNo, "!!" & Cells(i, 2)) = vbNo Then
  Exit Sub
 End If
Next i
End Sub
Вывести в MsgBox значение ячейки
 
Просьба подсказать Как мне вывести значение каждой ячейки из столбца B по порядку, Чтобы было в название диалогового окна значение из ячейки столбца B
Код
If MsgBox("Продолжить?", vbYesNo, "!!" & Cells(i, 2)) = vbNo Then
  Exit Sub
End If

  Range("B2:B31").Select
   Selection.ClearContents
    Next i
Сумма элементов массива
 
Добрый день! Впервые столкнулась с проблемой массивов.
написала код, все работало. Все было отлично, скопировала код, после перестало все работать, сумма элементов массива выдает всегда ноль, может кто знает в чем проблема, при том что на этом коде все считалось. По заданию дан  массив В(10) нужно найти сумму и количество отрицательных элементов. Нигде не могу найти ответ. Файл с кодом в приложении.
Код
Sub test()
    Dim i As Integer, sum As Integer, o As Integer, ch As Integer
     Dim B() As Integer
    summ = 0
    o = 0
      
   n = InputBox("n=")
    ReDim B(n)
    
    
    For i = 0 To n
    If B(i) < 0 Then
    o = o + 1
    sum = sum + B(i)
    End If
    
Next i
'ch = sum / o

 MsgBox "Êîëè÷åñòâî îòðèöàòåëüíûõ ýëåìåíòîâ â ìàññèâå: " & o & vbNewLine & "Èõ ñóììà ðàâíà=" & sum
 'ch = Format(ch, "###0.0")
'MsgBox "×àñòíîå =" & ch
  
 
End Sub
удалить значение, если оно не равно числу
 
Как удалить значение, если в следующей ячейке, под ней, стоит слово. Если так удаляем, если стоит цифра то не удаляем. у меня не работает мой код(
Код
With Sheets("Заказ")
      For Each y In Sheets("Заказ").Range("F1:F250")
      If LCase(y.Text) Like "*кол-во*" Then
             
      
         If IsNumeric(y.Offset(1, 0)) = False Or y.Offset(1, 0) = "" Then
      y.EntireRow.Delete
      End If
          End If
        
         Next y
      End With
Изменено: kleo90 - 27.06.2016 17:10:07
Копировать строки по условию
 
Подскажите как мне так скопировать строки C помощью VBA, чтобы переносились на новый лист заказы, только те у которых я проставила стоимость,но пока получается только так. Он переносит все, если находит  не пустое значение в столбце F.
Код
Sub Copy2()
Dim currentRow As Integer
Dim sourceCol As Integer
Dim LastRow As Integer
Dim currentRowValue
Dim sourcews As String
sourcews = ActiveSheet.Name 
sourceCol = 6   
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
 
For currentRow = 7 To RowCount  
    currentRowValue = Cells(currentRow, sourceCol).Value
    If Not IsEmpty(currentRowValue) Then
          Rows(currentRow).Copy
          Worksheets("Заказ").Select
          LastRow = Cells(Rows.Count, sourceCol).End(xlUp).Row
          Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1)).PasteSpecial Paste:=xlPasteValues
          Worksheets("корпуса").Select
    End If
Next
End Sub

Посчитать тариф если рабочих часов в будни дни больше 8
 
Никак не могу сообразить как правильно поставить условия в ЕСЛИ на дни недели, если она заданы просто как- Пн ВТ Ср. В задании надо посчитать тариф если рабочих часов в будни дни больше 8. Файл в приложении
Рассчитать стоимость, начисление от начала до конца зимнего периода
 
Как мне обозначить период, чтобы считалась формула: Сезонность =Оплата  * 5%
Но только при условии что дата попадает между началом и концом периода
Вставка строк по условию
 
Просьба подсказать, как мне вставить новые строки макросом, так чтобы они шли не после строки итогов, а всегда вставлялись перед ними.
Пока у меня только вставляться в последнюю заполненную ячейку
Код
With Application.Workbooks.Item("н и без.xlsx")
   For Each y In wl1.Range("B3:B663")
   rk = .Worksheets("учет по месяцам").Cells(Rows.Count, 3).End(xlUp).Row
    If .Worksheets("учет по месяцам").Columns(2).Find(y) Is Nothing Then
                .Worksheets("учет по месяцам").Cells(rk + 1, 2).Value = y
                    .Worksheets("учет по месяцам").Cells(rk + 1, 3).Value = y.Offset(, 1)
                    
                    .Worksheets("учет по месяцам").Cells(rk + 1, 4).Value = y.Offset(, 2)
                    .Worksheets("учет по месяцам").Cells(rk + 1, 5).Value = y.Offset(, 3)
                   .Worksheets("учет по месяцам").Cells(rk + 1, 6).Value = y.Offset(, 4)
                   .Worksheets("учет по месяцам").Cells(rk + 1, 11).Value = "Б"
                   End If
           
        Next y
 End With

End Sub
Ошибка 13 и 2042
 
Кто н может сказать что за ошибка ткая, вчера все работала сегодня открываю файл, сначало все сработало, ничего не меняла, и вдруг ошибку 13 и 2042 выдает на строке If LCase(x.Value) = "*родс*" Then

Не понимаю в чем может быть проблема
Код
Sub example2()
 Dim x As Range
    Dim wb0 As Workbook
    Dim wl0 As Worksheet
    Application.ScreenUpdating = False
    Set wb0 = ThisWorkbook
    Set wl0 = wb0.ActiveSheet
    wb0.Activate


 With Workbooks.Open("C:\Учет.xlsx")


    For Each x In wl0.UsedRange.Cells
            If LCase(x.Value) = "*окна*" Then
            
                rk = .Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row
                If Not .Worksheets("Лист1").Columns(3).Find(x.Offset(, -2)) Is Nothing Then
                    
                End If
            End If
        Next x
 
    End With
End Sub
  
Изменено: kleo90 - 12.05.2016 13:04:10
Сравнить диапазоны и вставить значения с толбец
 
Как мне прописать условие чтобы  по найденному номеру заказу, во второй файл учет2 подбивалась сумма
Это что то типа впр как я подозреваю
Пока только переноситься номер заказа
Ника не хочет работать(
Код
Sub example2()
    Dim x As Range
    Dim wb0 As Workbook
    Dim wl0 As Worksheet
    Application.ScreenUpdating = False
    Set wb0 = ThisWorkbook
    Set wl0 = wb0.ActiveSheet
    wb0.Activate
    With Workbooks.Open("C:\Учет .xlsx")
        For Each x In wl0.UsedRange.Cells
            If LCase(x.Value) Like "*окна*" Then
                rk = .Worksheets("Лист1").Cells(Rows.Count, 3).End(xlUp).Row
                If Not .Worksheets("Лист1").Columns(3).Find(x.Offset(, -2), , , 1) Is Nothing Then
                    .Worksheets("Лист1").Cells(rk + 1, 3).Value = x.Offset(, -2)
                End If
            End If
        Next x

    End With   
End Sub
Ошибка обращения к листу
 
Может кто н объяснить в чем ошибка?
Говорит что ошибка в строке wl.Cells(rk + 1, 3).Value = x.offcet(0, -2)
Не могу понять в чем дело
Код
Sub example2()
Dim x As Range

Dim wb As Workbook, wb0 As Workbook
Dim wl As Worksheet, wl0 As Worksheet
Application.ScreenUpdating = False
Set wb0 = ThisWorkbook
Set wl0 = wb0.ActiveSheet
Set wb = Workbooks.Open(Filename:="C:\Учет.xlsx")
Set wl = wb.Worksheets("Лист1")

    wb0.Activate


For Each x In wl0.UsedRange.Cells
If LCase(x.Value) Like "*мост*" Then


With Application.Workbooks.Item("Учет РОДС.xlsx")
rk = Workbooks("Учет РОДС.xlsx").Worksheets("Лист1").Columns("C:C").Rows(65536).End(xlUp).Row + 1
           If Sheets("Лист1").Range("C:C").Find(What:=x.Offset(0, -2), LookAt:=xlWhole)  Then
               wl.Cells(rk + 1, 3).Value = x.offcet(0, -2)
              End If
            End With
        End If
    Next x
End Sub
копирование данных из одной книги в другую по условию
 
Помогите,плиз, уже который день собираю ко по частям, осталась последняя часть) Мне надо чтобы в одной таблице в 3 столбценаходил все ячейки со словом роллеты и чтобы из по нашедшим ячейкам, переносил данные(номер заказа)  в новую книгу. Но чтобы не повторялись значения в новой книги, что то типа добавления новых заказов. Код простой, но никак не получается.
Код
Sub example2()
Dim x As Range

Application.ScreenUpdating = False
Workbooks.Open Filename:="C:\Users\Documents\Учет.xlsx"
For Each x In ActiveSheet.UsedRange.Cells
If LCase(x.Value) Like "*Роллеты*" Then

rk = Workbooks("Учет.xlsx").Worksheets("Лист1").Columns("C:C").Rows(65536).End(xlUp).Row + 1

        
 Sheets("Лист1").Cells(rk, 3).Value = x.offcet(0,-1)
 
End If
Next x



End Sub
перебор всех заполненных ячеек на активном листе
 
Помоги плиз! Уже который день не могу справиться с кодом простым, никак не настроить. Нужно найти все слова заданные на листе, а он не ищет, выдает что то типа ошибка 2007 и error 13, typу mismatch . Что делать( Если искать цифры, он вроде подкрашивает, но ошибку 13 все равно выдает. причем ошибка именно в этом
If x.Value = "сентябрь" Then
Код
Sub example2()
Dim x As Range
For Each x In ActiveSheet.UsedRange.Cells
If x.Value = "сентябрь" Then
x.Interior.ColorIndex = 5
End If
Next x
End Sub
Перенос из одной книги данные в другую
 
Люди помогите, никак не пойму как мне перенести из одной книги данные в другую, из первой книги учет нахожу все строки с нужным словом, потом надо перенести номер заказов в найденных строках в столбец С в книгу учет2. Вот что получилось у меня, но не работает( Ошибка номер 9 лезет(Кто может подскажите
Код
Sub Ut()

Dim lLastRow As Long
   Dim rFndRng As Range
    Set rFndRng = Columns("D:D").Find("*родс*", , xlValues, xlWhole)
    If rFndRng Is Nothing Then
        MsgBox "Нет"
    Else
       
  
      
       Workbooks.Open Filename:="C:\Users\Documents\Учет РОДС.xlsx"
       
     
  If Workbooks("Учет.xlsx").Worksheets("учет по месяцам").rFndRng.Offset(, 1) <> Workbooks("Учет РОДС.xlsx").Worksheets("Лист1").Columns("C:C") Then
     rk = Workbooks("Учет РОДС.xlsx").Worksheets("Лист1").Columns("C:C").Rows(65536).End(xlUp).Row + 1
     Sheets("Лист1").Cells(rk, 3) = rFndRng.Offset(, 1).Value
       
        End If
    End If
   End Sub
Поиск значение и копирование в другую книгу
 
Доброго времени суток! Подскажите пжл как мне скопировать последние значения, по определенному признаку, т.е. если в ячейке есть слово родс, то нужно скопировать в другую книгу введенные данные, но нужно скопировать только уникальные значения,только что введенные по новому заказу.
Нужно переносить только из ячейки номер заказа и закупка, в новый файл в столбцы сумма и №заказа
Страницы: 1 2 След.
Наверх