Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Изменение макроса для указания рядом с числами месяца содержимого ячеек с красным шрифтом, из столбцов первой таблицы
 
#1
20.12.2018 07:38:30
НАЧАЛО

Имеется таблица, в ней по числам месяца руками вносятся данные. Макрос выбирает из столбцов таблицы ячейки с красным шрифтом и помещает их в другую таблицу на листе. Таблица содержит 10 столбцов т.е. с 1 по 10 число. Необходимо видоизменить макрос так что бы он работал с 31-ним столбцом т.е. с 1 по 31 число месяца и n-ным количеством строк. Или если можно то в коде макроса должен быть прописан диапазон ячеек с которым он работает.
Код
Sub RedFontMerge()
    Dim arrOut(1 To 10, 1 To 2), strS As String, lngI As Long, lngJ As Long
     
    For lngJ = 1 To 10
        For lngI = 2 To ActiveSheet.UsedRange.Rows.Count
            If Cells(lngI, lngJ + 1).Font.Color = vbRed Then
                strS = strS & "," & Cells(lngI, lngJ + 1).Value
            End If
        Next lngI
        arrOut(lngJ, 1) = lngJ: arrOut(lngJ, 2) = Mid(strS, 2, Len(strS) - 1)
        strS = ""
    Next lngJ
    [AH2].Resize(10, 2).NumberFormat = "@"
    [AH2].Resize(10, 2) = arrOut
End Sub
 
 
 
#2
20.12.2018 08:44:49
даже не открывал файл.
Цитата
Таблица содержит 10
т.е. с 1 по 10 число
Не вызывает ни каких мыслей?
Цитата
т.е. с 1 по 31
Код
arrOut(1 To 10,
lngJ = 1 To 10
.Resize(10, 2)
 
 
 
#3
20.12.2018 09:27:42
Александр Моторин, простите нет не вызывает. Я в VBA не силен.
 
 
 
#4
21.12.2018 20:33:35
CEHATOP, число столбцов определяется автоматически, после диапазона чисел в первой строке должна быть пустая ячейка
Код
Sub RedFontMerge()
Dim arrOut(), strS As String, lngJ As Long, c As Range
  arrOut = WorksheetFunction.Transpose(Range(Cells(1, 2), Cells(1, 2).End(xlToRight)).Value)
  ReDim Preserve arrOut(1 To UBound(arrOut), 1 To 2)
  For lngJ = 1 To UBound(arrOut)
    strS = ""
    For Each c In Range(Cells(2, lngJ + 1), Cells(Rows.Count, lngJ + 1).End(xlUp))
      If c.Font.Color = vbRed Then
        strS = strS & "," & c.Value
      End If
    Next
    arrOut(lngJ, 2) = Mid(strS, 2)
  Next lngJ
  Columns(lngJ + 3).NumberFormat = "@"
  Cells(2, lngJ + 2).Resize(UBound(arrOut), 2).Value = arrOut
End Sub
 
 
 
Страницы: 1
Наверх