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

Страницы: 1 2 След.
Нумерация строк по содержанию в ячейках. VBA
 
Hashtag, добрый день! В вашем коде можно было поменять часть одной строки
У Андрей VG, безусловно красивый код.
Код
Sub num()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim lr&
lr = Cells(Rows.Count, 2).End(xlUp).Row
lr = IIf(lr < 5, 5, lr)
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
For i = 5 To lr
    If InStr("Один", Cells(i, 5)) > 0 Then 'Здесь поменял условие
        K = K + 1
        Cells(i, 1) = K
    End If
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Макрос: вставка строки по активной ячейке, Нужно по нажатию кнопки вставить строку в таблицу снизу активной в данный момент ячейки
 
Попробуйте макрос, код в модуль листа, кнопки добавил в быстрый доступ, с защитой листа, как я понял Вы разобрались.
Код
'Удаление активной строки
Sub RowDelete()
For Each LObj In ListObjects
    If Not Intersect(LObj.Range, ActiveCell) Is Nothing Then
        With LObj
            LObjRow = .Range.Row
            ACelRow = ActiveCell.Row
            RowtoDelete = ACelRow - LObjRow
            For Each cel In .ListRows(RowtoDelete).Range
               If cel.Value <> "" Then Exit Sub
            Next
            .ListRows(RowtoDelete).Delete
            .DataBodyRange(.ListRows.Count, 1).Activate
        End With
Exit For
    End If
Next
End Sub
'Добавление строки внизу
Sub RowInsert()
For Each LObj In ListObjects
    If Not Intersect(LObj.Range, ActiveCell) Is Nothing Then
        With LObj
            .ListRows.Add
            .DataBodyRange(.ListRows.Count, 1).Activate
        End With
Exit For
    End If
Next
End Sub
Изменено: Smurov - 06.01.2020 16:04:02
Скопировать данные из закрытой книги в разные ячейки и листы
 
Voltz, Ну правильно, как в Вашем первоначальном посте - 'Записываем данные на активный лист книги, с которой запустили макрос.
Я понял, что Вы все три значения хотите вставить на один лист, т.е. на Лист1
Объединение данных из столбцов по условию
 
Валентина83, когда необходимо, чтобы происходило заполнение столбца: при изменении данных на листе, при нажатии кнопки,...?
Упорядочить по убыванию часть массива, выбраная из большого массива по одному параметру
 
Добрый день!
Вариант с макросом.
Код в модуль листа.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arr, WDay As String, DayParam As String
If Target.Address <> "$V$1" Then Exit Sub
ActiveSheet.Range("S3:W" & Cells(Rows.Count, "S").End(xlUp).Row + 1).ClearContents
arr = ActiveSheet.Range("N2:Q" & Cells(Rows.Count, "Q").End(xlUp).Row)
On Error Resume Next
DayParam = Trim(LCase(CStr([V1].Value)))
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr)
        WDay = WeekdayName(Weekday(CDate(arr(i, 2)), vbMonday), , vbMonday)
        If DayParam = WDay And arr(i, 4) <> 0 Then
            .Add .Count, Array(.Count + 1, arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4))
        End If
    Next
[S3].Resize(.Count, 5) = Application.Transpose(Application.Transpose(.items))
[S3].Resize(.Count, 5).Sort Key1:=[W3], Order1:=xlDescending
End With
End Sub
Упорядочить по убыванию часть массива, выбраная из большого массива по одному параметру
 
Андрей VG,
Андрей, добрый вечер! Впечатлён Вашим решением! Подскажите, пожалуйста, где можно почитать про то как Вы это сделали. Я всегда делал через технологию ADO, а это очень долго работало.

Заранее благодарен.
Меню-раскладка. Вывод данных диапазона в одной ячейке.
 
Julia222,
1. Какие столбцы могут изменяться?
2. Каким образом эти данные могут изменяться?
3. Что подразумевается под выделенными ячейками?
Скопировать данные из закрытой книги в разные ячейки и листы
 
Voltz,попробуйте такой макрос, поменьше кода. Если необходимо много значений из разных листов брать, то думаю целесообразно будет
конструкцию With со словариком использовать.
Код
Sub Get_Value_From_Close_Book()
    Dim sShName As String, vAddress, vData
    Dim objCloseBook As Object
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Users\Мария\Downloads\Книга12.xlsm")
    vAddress = Array("G8", "I10", "C14")
    'получаем значения
    vData0 = objCloseBook.Sheets("Лист1").Range("G8").Value
    vData1 = objCloseBook.Sheets("Лист1").Range("I10").Value
    vData2 = objCloseBook.Sheets("Лист2").Range("C14").Value
    vData = Array(vData0, vData1, vData2)
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    For i = 0 To UBound(vData)
        If IsArray(vData(i)) Then
            Range(vAddress(i)).Resize(UBound(vData(i), 1), UBound(vData(i), 2)).Value = vData(i)
        Else
            Range(vAddress(i)) = vData(i)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Изменено: Smurov - 02.01.2020 19:14:34
Скопировать данные из закрытой книги в разные ячейки и листы
 
Цитата
Voltz написал:
А как, компактней сделать весь макрос
Добрый день!
Может попробуете забирать в массив адреса и значения ячеек,
затем в одном получении объекта делать копирование и
только потом закрывать объект.
Сортировка значений с сохранением структуры порядка пробелов
 
Добрый день!
Решение при помощи макроса.
Код
Sub SortWithBlanks()
With Sheets(1).Columns(1)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastRow
        If Trim(.Cells(i).Value) = "" Then .Cells(i).Offset(1, 0).CurrentRegion.Sort Key1:=.Cells(i).Offset(1, 0), Order1:=2
    Next
End With
End Sub
Распределить данные из файла txt по столбцам EXCEL
 
artyrH, Да Вы правы, спасибо, просто я люблю макросы)
Распределить данные из файла txt по столбцам EXCEL
 
Есть решение в три шага.
1. Импортируете текст. Разделитель ]
2. В первой строке Найти и заменить ,[ на пусто.
3.В код листа вставляете макрос и запускаете его.

Разумеется, все это можно одним макросом сделать.
Код
Sub CelSplit()
Dim Record
j = 2
For i = 1 To [A1].CurrentRegion.Columns.Count
    Record = Split(Cells(1, i).Value, ",")
    Cells(j, 1).Resize(, 6) = Record
    j = j + 1
Next
End Sub
Изменено: Smurov - 28.12.2019 16:26:34
Распределить данные из файла txt по столбцам EXCEL
 
Добрый день!
Файл приложите, пжл.
И у Вас в строке 5 потенциальных столбцов, а не 6.
Последовательная сортировка выделенных строк по определенным столбцам, Помогите найти макрос для данной операции
 
Цитата
Vithud написал:
Я копирую его в персональные проекты в виде модуля.
Добрый день!
Можете в этот модуль вставить вспомогательную вот такую процедуру
Код
Public Sub NesRangeSort()
'Определяем первый диапазон
Dim FirstRange As Range
'Определяем последнюю заполненную строку первого диапазона без итога
FLRow = Sheets("Лист4").[A1].CurrentRegion.Rows.Count - 1
Set FirstRange = Sheets("Лист4").Range(Cells(1, 1), Cells(FLRow, 21))
Call SortRangeBy(FirstRange, Array(21, 16, 3), True)

'Определяем второй диапазон
Dim SecondRange As Range
'Определяем первую строку втрого диаазона
SFRow = FLRow + 3
'Определяем конец второго диапазона без итогов
SLRow = Sheets("Лист4").Cells(Rows.Count, 1).End(xlUp).Row
Set SecondRange = Sheets("Лист4").Range(Cells(SFRow, 1), Cells(SLRow, 21))
Call SortRangeBy(SecondRange, Array(21, 16, 3))

End Sub
Процедуру написал исходя из расположения Ваших диапазонов на листе.
Пробуйте.
Кнопка запуска макроса слева от таблицы.
Изменено: Smurov - 27.10.2019 12:50:22
Удалить с листа все - кроме заданной фразы. С любыми значениями между определенными тегами.
 
Михаил Иванченков,Макрос Пытливый, конечно более универсален, поскольку не зависит от конкретного столбца.
Удалить с листа все - кроме заданной фразы. С любыми значениями между определенными тегами.
 
Добрый вечер!
Можете использовать такой макрос.
Код
Public Sub DelSomeRows()

LastRow = Sheets(1).UsedRange.Rows.Count
With Sheets(1).Columns(3)
    For i = LastRow To 1 Step -1
        If InStr(.Cells(i).Value, "<SubCategory>") = 0 Then .Cells(i).EntireRow.Delete
    Next
End With
End Sub
Создание выборки по датам из одного списка дат
 
Добрый день!
Посмотрите, пожалуйста, решение макросом.
Проверяйте.
Код
Public Sub Report()

LRow = Cells(Rows.Count, 1).End(xlUp).Row 'последняя заполненная строка в столбце с датами
arr = Range(Cells(1), Cells(LRow, 1))
For i = 1 To UBound(arr)
    If arr(i, 1) <> "" And DatePart("yyyy", CDate(arr(i, 1))) = DatePart("yyyy", Date) Then
        If CDate(arr(i, 1)) = Date Then
            TodayEx = TodayEx + 1
        End If
        If DatePart("ww", CDate(arr(i, 1)), vbMonday) = DatePart("ww", Date, vbMonday) And CDate(arr(i, 1)) <= Date Then
            ThisWeekEx = ThisWeekEx + 1
        End If
        If DatePart("ww", CDate(arr(i, 1)), vbMonday) - DatePart("ww", Date, vbMonday) = -1 Then
            PrevWeekEx = PrevWeekEx + 1
        End If
        If DatePart("m", CDate(arr(i, 1))) = DatePart("m", Date) And CDate(arr(i, 1)) <= Date Then
            ThisMonthEx = ThisMonthEx + 1
        End If
        If DatePart("m", CDate(arr(i, 1))) - DatePart("m", Date) = -1 Then
            PrevMonthEx = PrevMonthEx + 1
        End If
        If DatePart("q", CDate(arr(i, 1))) = DatePart("q", Date) And CDate(arr(i, 1)) <= Date Then
            ThisQuarterEx = ThisQuarterEx + 1
        End If
        If CDate(arr(i, 1)) <= Date Then
            ThisYearEx = ThisYearEx + 1
        End If
    End If
Next

Cells(18, 8) = TodayEx
Cells(18, 9) = ThisWeekEx
Cells(18, 10) = PrevWeekEx
Cells(18, 11) = ThisMonthEx
Cells(18, 12) = PrevMonthEx
Cells(18, 13) = ThisQuarterEx
Cells(18, 14) = ThisYearEx


End Sub
Изменено: Smurov - 08.10.2019 14:10:21
Подстановка в конкретную ячейки числа из другой таблицы и если в конкретной ячейке уже стоит число то подстановка в ячейке ниже
 
Добрый день!
Вариант с макросом.
Код поместитить в модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.Range("D9:D" & Cells(Rows.Count, 4).End(xlUp).Row)
If Not Intersect(Target, WorkRange.Cells) Is Nothing Then
    If Target.Value = "сделал" Then
        RowToCopy = Sheets("итоговая").Cells(8, 2).CurrentRegion.Rows.Count + 8
        Set RangeToCopy = Range(Target.Offset(, -2), Target.Offset(, -1))
        RangeToCopy.Copy Destination:=Worksheets("итоговая").Cells(RowToCopy, 2)
    End If
End If
End Sub
Как просуммировать данные с нескольких листов, в том числе по условию
 
Цитата
Ver написал:
Необходимо создать выписку за год на отдельном листе, т.е просуммировать данные по статьям со всех листов,
Я правильно понимаю, что под статьей понимается уникальная комбинация первых трех столбцов таблицы?
Как просуммировать данные с нескольких листов, в том числе по условию
 
Добрый вечер.
Файл не открывается.
Нужно только формулами, макрос не подойдет?
Как в таблице не дать повторить два критерия одновременно, какую формулу прописать в "проверке данных"
 
Пробуйте
Код
Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.Range("A10:D" & Cells(Rows.Count, 4).End(xlUp).Row)
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 3)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 4).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 4))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -3).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 3).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If
End Sub
Как в таблице не дать повторить два критерия одновременно, какую формулу прописать в "проверке данных"
 
Stounv17,Адоптировал как понял. Проверяйте.
Для данного кода строки сверху и снизу должны быть пустыми как в файле.

Насчет защиты ни разу не делал.
Надо разобраться.
Если что выложу код.
Код
Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.[A10].CurrentRegion
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 3)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 4).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 4))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -3).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 3).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If
End Sub
 
Изменено: Smurov - 25.08.2019 16:30:21
Как в таблице не дать повторить два критерия одновременно, какую формулу прописать в "проверке данных"
 
По второму вопросу из поста 4 проверяйте
Код
Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.[B5].CurrentRegion
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 2)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 2).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If

End Sub
Изменено: Smurov - 25.08.2019 15:16:46
Как в таблице не дать повторить два критерия одновременно, какую формулу прописать в "проверке данных"
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Set WorkRange = ActiveSheet.[B5].CurrentRegion
    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
        Next
        If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
End Sub

Stounv17, добрый день!
Первый вопрос закрыл.
Изменено: Smurov - 25.08.2019 14:28:51
Как перенести отдельные блоки одного столбца в разные столбцы?
 
k61, Не подскажите, где можно побольше почитать про SpecialCells, а то справка крайне скупая.
Заранее спасибо.
Как перенести отдельные блоки одного столбца в разные столбцы?
 
Уважаемые форумчане, добрый день!
Подскажите, пжл, правильно ли я понимаю, что метод SpecialCells, который применил  k61, можно применить только к столбцу или строке?
Спасибо.  
Как в таблице не дать повторить два критерия одновременно, какую формулу прописать в "проверке данных"
 
Stounv17,
Добрый вечер!
Скопируйте данный код в модуль листа.
Попробуйте данный макрос, пожалуйста. Из первого столбца я удалил проверку данных.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Set WorkRange = ActiveSheet.[B5].CurrentRegion
    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add CStr(arr(i, 1)) & ";" & CStr(arr(i, 3)), ""
        Next
        If oDic.exists(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value)) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
End Sub
Изменено: Smurov - 25.08.2019 00:08:00
Умеет ли excel распознавать цвет (стиль) для заполнения данными?
 
Добрый день!
Попробуйте такой код.
Спасибо.
Код
Public Sub RangesCopy()
Application.ScreenUpdating = False
Dim TextToCopy As String
With CreateObject("scripting.dictionary")
    Sheets(1).Activate
    TextToCopy = Cells(2, 2).Value
    For i = 2 To ActiveSheet.UsedRange.Rows.Count
       .Add .Count, TextToCopy
       If Cells(i, 2).Style <> Cells(i + 1, 2).Style Then TextToCopy = Cells(i + 1, 2).Value
    Next
Cells(2, 1).Resize(.Count, 1) = Application.Transpose(.items)
End With
Application.ScreenUpdating = True
End Sub
Изменено: Smurov - 18.08.2019 18:15:38
Макросом скопировать только строки таблицы с не пустыми ячейками во втором столбце
 
Цитата
abc1 написал:
если что как нибудь индекс столбца прикручу или возьму значение из ячейки, в которой формула возвращает номер столбца
Доделал макрос, процедура находит нужный номер столбца.
Спасибо.
Код
Public Sub RangeCopy()
Dim arr()
With CreateObject("scripting.dictionary")
    Set a = Workbooks("Лист Microsoft.xlsm").Sheets("vv")
    arr = a.UsedRange.Value
    'Находим номер столбца с заголовком "наличие"
    NumCol = Application.Match("наличие", Application.Index(arr, 1))
    'Определяем количество столбцов в масииве
    QntCol = UBound(arr, 2)
    For i = 1 To UBound(arr)
        If arr(i, NumCol) <> "" Then
            .Add .Count, Application.Index(arr, i)
        End If
    Next
    arr = .items
    Set b = ThisWorkbook.Sheets("vv")
    b.Cells(1).Resize(.Count, QntCol) = Application.Transpose(Application.Transpose(arr))
    b.ListObjects.Add(xlSrcRange, b.Cells(1).CurrentRegion, , xlYes).Name = a.ListObjects(1).Name
End With
Изменено: Smurov - 18.08.2019 14:23:37
Макросом скопировать только строки таблицы с не пустыми ячейками во втором столбце
 
Юрий М, спасибо, поправил пост.
Спасибо.
Страницы: 1 2 След.
Наверх