Sub iFindWord_Color()
Dim i As Long
Dim iLastRow As Long
Dim temp As String
Dim FoundCell As Range
Dim Priznak As Boolean
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("A2:A" & iLastRow).Interior.ColorIndex = 2
For i = 2 To iLastRow
Priznak = False
If InStr(1, Cells(i, "C"), "-") > 1 And InStr(1, Cells(i, "C"), "тК ") > 1 Then
temp = Split(Cells(i, "C"), "тК ")(1)
Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
If Not FoundCell Is Nothing Then
Cells(i, 1).Interior.ColorIndex = 6
End If
Else
If InStr(1, Cells(i, "B"), "тК ") > 1 Then
temp = Split(Cells(i, "B"), "тК ")(1)
Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
If Not FoundCell Is Nothing Then
Priznak = True
End If
End If
If InStr(1, Cells(i, "C"), "тК ") > 1 Then
temp = Split(Cells(i, "C"), "тК ")(1)
Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
If Not FoundCell Is Nothing Then
Priznak = True
End If
End If
If Priznak Then Cells(i, 1).Interior.ColorIndex = 6
End If
Next
End Sub
Подскажите пожалуйста как реализовать следующую задачу:
Попробуйте макрос
Код
Sub iFindWord_Color()
Dim i As Long
Dim iLastRow As Long
Dim temp As String
Dim FoundCell As Range
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("A2:A" & iLastRow).Interior.ColorIndex = 2
For i = 2 To iLastRow
If InStr(1, Cells(i, "C"), "-") > 1 And InStr(1, Cells(i, "C"), "тК ") > 1 Then
temp = Split(Cells(i, "C"), "тК ")(1)
Else
temp = Split(Cells(i, "B"), "тК ")(1)
End If
Set FoundCell = Columns("F").Find(temp, , xlValues, xlPart)
If Not FoundCell Is Nothing Then
Cells(i, 1).Interior.ColorIndex = 6
End If
Next
End Sub
Sub iAreas()
Dim Rng_A As Range
Dim iLastRowA As Long
Dim Rng_D As Range
Dim iLastRowD As Long
Dim n As Integer
iLastRowA = Cells(Rows.Count, "A").End(xlUp).Row
iLastRowD = Cells(Rows.Count, "D").End(xlUp).Row
For Each Rng_D In Range("D2:D" & iLastRowD).SpecialCells(2, 1).Areas
For Each Rng_A In Range("A2:A" & iLastRowA).SpecialCells(2, 1).Areas
If Rng_D.Count = Rng_A.Count Then
For n = 1 To Rng_D.Count
If Rng_D(n, 1) = Rng_A(n, 1) Then
Else
Exit For
End If
Next
If n = Rng_D.Count + 1 Then Rng_D(, 2) = Rng_A(, 2)
End If
Next
Next
Function iSplit(cell$)
Dim mo As Object
Dim i As Integer
Dim n As Integer
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "[А-ЯЁ][а-яё]+"
If .test(cell) Then
Set mo = .Execute(cell)
For i = 0 To mo.Count - 1
iSplit = iSplit & mo(i) & " "
n = n + Len(mo(i))
Next
iSplit = iSplit & Mid(cell, n + 1, 6)
Else
iSplit = ""
End If
End With
End Function
посчитать только числа и вывести сумму в столбец F
Код
Sub GetSum()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("F2:F" & iLastRow).ClearContents
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+,\d+"
For i = 2 To iLastRow
If .Test(Cells(i, "E")) Then
Set mo = .Execute(Cells(i, "E"))
For n = 0 To mo.Count - 1
Cells(i, "F") = Cells(i, "F") + CDbl(mo(n))
Next
End If
Next
End With
End Sub
Sub FindLargeWord() 'для наибольшей длины слова в ячейке
Dim i As Long
Dim n As Long
Dim arr
Dim LargeWord As String
Dim temp As String
Dim FoundWord As Range
Columns("A:B").Interior.ColorIndex = 2
For i = 2 To 11
arr = Split(Cells(i, "B"), " ")
temp = arr(0)
For n = 0 To UBound(arr)
If Len(arr(n)) > Len(temp) Then
LargeWord = arr(n)
temp = LargeWord
Else
LargeWord = temp
End If
Next
Set FoundWord = Columns(5).Find(LargeWord, , xlValues, xlPart)
If Not FoundWord Is Nothing Then
Range("A" & i & ":B" & i).Interior.ColorIndex = 6
End If
Next
End Sub
Sub FindArticul()
Dim i As Long
Dim iLastRow As Long
Dim cell As Range
Dim List1 As Worksheet
Set List1 = ThisWorkbook.Worksheets("Лист1")
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B3:C" & iLastRow).ClearContents
With List1
For i = 3 To iLastRow
Set cell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
If Not cell Is Nothing Then
Cells(i, "B") = cell.Offset(, 1) 'наименование
Cells(i, "C") = cell.Offset(, 2) 'ячейка хранения
Else
MsgBox "На листе1 нет артикула: " & Cells(i, "A")
End If
Next
End With
End Sub
Function iRU(cell$)
With CreateObject("VBScript.RegExp")
.Global = True
.ignorecase = True
.Pattern = "//([A-Z\.]+)(?=/)"
If .test(cell) Then
iRU = .Execute(cell)(0).submatches(0)
Else
iRU = ""
End If
End With
End Function
Для модели UDF
Код
Function iModel(cell$)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = ": ?([A-Z0-9]+)(?=,)"
If .test(cell) Then
iModel = .Execute(cell)(0).submatches(0)
Else
iModel = ""
End If
End With
End Function
Затем ищем из этих значений максимально встречающееся
Sub FindLastWord()
Dim i As Long
Dim arr
Dim LastWord As String
Dim FoundWord As Range
Columns("A:B").Interior.ColorIndex = 2
For i = 2 To 11
arr = Split(Cells(i, "B"), " ")
LastWord = arr(UBound(arr))
Set FoundWord = Columns(5).Find(LastWord, , xlValues, xlPart)
If Not FoundWord Is Nothing Then
Range("A" & i & ":B" & i).Interior.ColorIndex = 6
End If
Next
End Sub
Может, у кого-то было что-то похожее или есть идеи?
Макрос
Код
Sub iPoiskTown()
Dim j As Long
Dim k As Long
Dim n As Long
Dim FoundCell As Range
Dim arr
arr = Array("Москва", "Петербург", "Адлер")
For k = 1 To 3 'цикл по столбцам
For j = 0 To UBound(arr) 'цикл по городам
Set FoundCell = Columns(k).Find(arr(j), , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
n = n + 1 'счетчик вхождений городов в столбец
Else
n = 0
Exit For
End If
Next 'следующий город
If n = UBound(arr) + 1 Then
MsgBox "Все города находятся в " & Cells(1, k)
Exit Sub
End If
Next 'следующий столбец
End Sub
нужно удалить лишь те скобки, которые закрывают (01) и (21)
UDF
Код
Function iResult(cell$)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\((01|21)\)"
If .test(cell) Then
iResult = .Replace(cell, "$1")
Else
iResult = cell
End If
End With
End Function
Sub СКРЫТЬ()
'Rows("2:19").Select
'Selection.EntireRow.Hidden = True
Range("B1:B19").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
'Range("A1").Select
End Sub
Sub ОТКРЫТЬ()
'Rows("2:19").Select
'Selection.EntireRow.Hidden = False
'Range("A1").Select
Range("B1:B19").EntireRow.Hidden = False
End Sub
Sub iBlocks()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Range("B2:B" & iLastRow).Font.ColorIndex = 1
Range("B2:B" & iLastRow).Interior.ColorIndex = 2
For Each Rng In Range("B2:B" & iLastRow).SpecialCells(2, 2).Areas
For i = 1 To Rng.Count - 1
If Rng.Cells(i) = Rng.Cells(i + 1) Then
Else
Exit For
End If
Next
If i = Rng.Count Then
Rng.Cells.Font.ColorIndex = 3
Rng.Cells.Interior.ColorIndex = 6
End If
Next
End Sub
Тем у кого нет power query Таблица находится на Лист_1
Код
Sub Limits()
Dim FoundLimit As Range
Dim FirstAdr As String
Dim BeginDiapazon As Long
Dim EndDiapazon As Long
Dim iLastRow As Long
Dim iLastRow_1 As Long
Dim j As Integer
Dim limitNomer As Long
With ThisWorkbook.Worksheets("Лист_1")
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("G2:M" & iLastRow).ClearContents ' очищаем
iLastRow_1 = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
Set FoundLimit = .Columns("A").Find("Лимиты", , xlValues, xlWhole)
If Not FoundLimit Is Nothing Then
FirstAdr = FoundLimit.Address 'адрес первого вхождения
Do
limitNomer = FoundLimit.Offset(-1)
BeginDiapazon = FoundLimit.Row + 1
Set FoundLimit = .Columns("A").Find("Лимиты", After:=FoundLimit)
If FoundLimit.Address <> FirstAdr Then
EndDiapazon = FoundLimit.Row - 1
Else
EndDiapazon = iLastRow
End If
For j = BeginDiapazon To EndDiapazon ' цикл по диапазону наименований
If IsDate(Cells(j, 1)) Then
.Cells(iLastRow_1, "G") = Int(.Cells(j, 1)) '
.Cells(iLastRow_1, "H") = .Cells(j, 1) - Int(.Cells(j, 1))
.Cells(iLastRow_1, "I") = .Cells(j, 2)
.Cells(iLastRow_1, "J") = .Cells(j, 3)
.Cells(iLastRow_1, "K") = .Cells(j, 4)
.Cells(iLastRow_1, "L") = .Cells(j, 5) '
.Cells(iLastRow_1, "M") = limitNomer '
iLastRow_1 = iLastRow_1 + 1
End If
Next
Loop While FoundLimit.Address <> FirstAdr
End If
End With
End Sub
Function iResult(cell$)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
If .test(cell) Then
iResult = .Replace(cell, "")
Else
iResult = cell
End If
End With
End Function
Sub insertrow()
Dim tbl As ListObject
Dim n As Long
Dim k As Long
Dim i As Long
Set tbl = ActiveSheet.ListObjects(1)
For n = tbl.DataBodyRange.Rows.Count To 1 Step -1
k = tbl.DataBodyRange(n, 5)
For i = 1 To k - 1
tbl.ListRows.Add (n + i)
tbl.DataBodyRange(n + i, 1) = tbl.DataBodyRange(n, 1) + i
tbl.DataBodyRange(n + i, 2) = tbl.DataBodyRange(n, 2)
tbl.DataBodyRange(n + i, 3) = tbl.DataBodyRange(n, 3)
tbl.DataBodyRange(n + i, 4) = tbl.DataBodyRange(n, 4) / k
tbl.DataBodyRange(n + i, 4).NumberFormat = "#,###.00"
Next
tbl.DataBodyRange(n, 4) = tbl.DataBodyRange(n + 1, 4)
tbl.DataBodyRange(n, 4).NumberFormat = "#,###.0"
Next n
End Sub
собрать данные в одну таблицу из разных листов одной книги
При активном листе сборка запустить макрос
Код
Sub Sbor()
Dim FoundPart As Range
Dim WSH As Worksheet
Dim iLastRow As Long
Dim iLR As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
If iLastRow <> 1 Then Range("A2:E" & iLastRow).ClearContents
For Each WSH In Worksheets 'цикл по всем листам книги
If WSH.Name <> "сборка" Then
With WSH
Set FoundPart = .Rows(1).Find("партия", , xlValues, xlWhole)
If Not FoundPart Is Nothing Then
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
iLR = .Cells(.Rows.Count, 2).End(xlUp).Row
Cells(iLastRow, 1).Resize(iLR - 2) = .Name
.Range("A3:B" & iLR).Copy Cells(iLastRow, 2)
FoundPart.Offset(2).Resize(5, 2).Copy Cells(iLastRow, 4)
End If
End With
End If
Next WSH
End Sub