Sub Hexagone(Row As Integer, Col As Integer, Size As Integer)
Range(Cells(Row, Col), Cells(Row + 2, Col + 1)).Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Cells(Row, Col).Select
With Selection.Borders(xlDiagonalUp)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Cells(Row, Col + 1).Select
With Selection.Borders(xlDiagonalDown)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Cells(Row + 1, Col + 1).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Cells(Row + 2, Col + 1).Select
With Selection.Borders(xlDiagonalUp)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Cells(Row + 2, Col).Select
With Selection.Borders(xlDiagonalDown)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Cells(Row + 1, Col).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
If ((Row + 3) < (4 * Size - 1)) Then
Cells(Row + 3, Col).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End If
End Sub
Sub Grid()
Dim WB As Workbook
Dim WS As Worksheet
Dim Size As Integer
Dim Xn As Integer, Yn As Integer
Set WB = Excel.ActiveWorkbook
Set WS = WB.Worksheets("Ëèñò1")
WS.Activate
Size = 15
Range(Cells(1, 1), Cells(4 * Size - 1, 2 * Size)).Select
Selection.Clear
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Yn = 1
For y = 1 To Size
Xn = 1
For x = 1 To Size
Call Hexagone(Yn, Xn, Size)
Xn = Xn + 2
Next x
Yn = Yn + 4
Next y
Randomize
For Picture = 1 To 20
x = Int(Size * Rnd) + 1
y = Int(Size * Rnd) + 1
If (y Mod 2 = 0) Then
x = x + 1
End If
Cells(3 * y - 1, 2 * x - 1).Select
ActiveSheet.Pictures.Insert( _
"C:\Program Files (x86)\Microsoft Office\MEDIA\OFFICE14\AutoShap\BD18253_.wmf") _
.Select
Selection.ShapeRange.ScaleWidth 0.3016920425, msoFalse, msoScaleFromTopLeft
Next Picture
End SubSub order()
Dim WB As Workbook
Dim WS As Worksheet
Dim objRegExp As New RegExp
Dim pattern As String
Dim Dict As New Dictionary
Dim ResRow As Integer
Dim NumOrder As Integer
Set WB = Excel.ActiveWorkbook
Set WS = WB.ActiveSheet
' Ищем только цифры
pattern = "\d+"
With objRegExp
.Global = True
.IgnoreCase = True
.pattern = pattern
.MultiLine = True
End With
' Номер строки, с которой начинается запись результатов
ResRow = 10
' Проходим со 2 по 5 строки с заказами
For r = 2 To 5
' 2 - столбец с номерами заказов
Set objMatches = objRegExp.Execute(WS.Cells(r, 2))
For i = 0 To objMatches.Count - 1
Set objMatch = objMatches.Item(i)
NumOrder = objMatch.Value
' Если номер заказа раньше не встречался
If Not Dict.Exists(NumOrder) Then
Dict.Add NumOrder, ResRow
' Пишем в 1 столбец номер заказа
WS.Cells(ResRow, 1) = NumOrder
ResRow = ResRow + 1
End If
' Выписываем номера покупателей
If IsEmpty(WS.Cells(Dict.Item(NumOrder), 2)) Then
WS.Cells(Dict.Item(NumOrder), 2) = WS.Cells(r, 1)
Else
WS.Cells(Dict.Item(NumOrder), 2) = WS.Cells(Dict.Item(NumOrder), 2) & ", " & WS.Cells(r, 1)
End If
Next i
Next r
Set objRegExp = Nothing
End Sub
Dim mark_array
mark_array = Array(Me.mark0, Me.mark1)
Me.mark [i]Sub SumBad()
Dim WK As Workbook
Dim WS As Worksheet
Dim Bad_Sum As Integer
Set WK = Excel.ActiveWorkbook
Set WS = WK.ActiveSheet
Bad_Sum = 0
' Перебор строк
For r = 2 To 7
' Перебор столбцов
For c = 6 To 8
If WS.Cells(r, c).Style = "Плохой" And IsNumeric(WS.Cells(r, c)) Then
Bad_Sum = Bad_Sum + WS.Cells(r, c)
End If
Next c
Next r
' Вывод результата
WS.Cells(9, 6) = Bad_Sum
End Sub=СЦЕПИТЬ("images/"; A1)Dim WB As Workbook
Dim WS As Worksheet
Set WB = Excel.ActiveWorkbook
Set WS = WB.ActiveSheet
' Вместо 5 указать действительное количество строк
For r = 1 To 5
' Вместо 1 указать номер ячейки, в которой нужно провести изменения
WS.Cells(r, 1) = "images/" & WS.Cells(r, 1)
Next r=СЦЕПИТЬ(ЕСЛИ(ДЛСТР(ПСТР(A1;ПОИСК(" ";A1)+1;ПОИСК(",";A1)-ПОИСК(" ";A1)-1))<2;СЦЕПИТЬ("0";ПСТР(A1;ПОИСК(" ";A1)+1;ПОИСК(",";A1)-ПОИСК(" ";A1)-1));ПСТР(A1;ПОИСК(" ";A1)+1;ПОИСК(",";A1)-ПОИСК(" ";A1)-1));".";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Jan";"01";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Feb";"02";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Mar";"03";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Apr";"04";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="May";"05";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="June";"06";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="July";"07";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Aug";"08";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Sept";"09";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Oct";"10";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Nov";"11";ЕСЛИ(ЛЕВСИМВ(A1;ПОИСК(" ";A1;1)-1)="Dec";"12";"WTF"))))))))))));".";ПСТР(A1;ПОИСК(", ";A1)+2;ДЛСТР(A1)-ПОИСК(", ";A1)+2))нуб в кодинге
Sub GetProduct()
' Первая снизу непустая ячейка
Dim LastRow As Integer
' Номер столбца с количеством > 0 (A = 1, B = 2 и т.д.)
Dim PriceCol As Integer
PriceCol = 3
' Название листа с каталогом товаров
Dim PriceList As Worksheet
Set PriceList = Excel.Workbooks(1).Worksheets.Item("Лист2")
' Название листа, на который копируются нужные ячейки
Dim TotalList As Worksheet
Set TotalList = Excel.Workbooks(1).Worksheets.Item("Лист1")
' Значение ячейки с количеством товара
Dim Count As Object
' Массив номеров столбцов для копирования
Dim Cols
Cols = Array(1, 2)
' Счетчик строк для копирования
Dim CountRow As Integer
CountRow = 1
' Счетчик столбцов для копирования
Dim CountCol As Integer
LastRow = PriceList.Cells(Rows.Count, PriceCol).End(xlUp).Row
For i = 1 To LastRow
Set Count = PriceList.Cells(i, PriceCol)
If (IsNumeric(Count)) And (Count > 0) Then
CountCol = 1
For Each copycell In Cols
TotalList.Cells(CountRow, CountCol) = PriceList.Cells(i, copycell)
CountCol = CountCol + 1
Next
CountRow = CountRow + 1
End If
Next i
End SubCols = Array(1, 2) - сюда через запятую заносятся номера столбцов, откуда нужно будет копировать значения.
=ПСТР(A1;1;МИН(ЕСЛИОШИБКА(ПОИСК("9";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("8";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("7";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("6";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("5";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("4";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("3";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("2";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("1";A1;1);ДЛСТР(A1));ЕСЛИОШИБКА(ПОИСК("0";A1;1);ДЛСТР(A1)))-1)
Sub Main
Dim inc, row As Integer
Dim rows, col As Integer
Dim x As Object
inc = 60 ' На сколько увеличить число
rows = 20 ' Количество просматриваемых строк
col = 0 ' Номер столбца для увеличения значений
oDoc = ThisComponent
row = 0
Do While (row < rows)
x = oDoc.Sheets(0).getCellByPosition(col, row) ' Первая страница текущего элемента (индекс 0)
' Проверка типа ячейки
Select Case x.Type
' Если число
Case com.sun.star.table.CellContentType.VALUE
oDoc.Sheets(0).getCellByPosition(col, row).setValue(x.Value + inc)
' Если текст
'Case com.sun.star.table.CellContentType.TEXT
' Если пусто
'Case com.sun.star.table.CellContentType.EMPTY
' Если формула
'Case com.sun.star.table.CellContentType.FORMULA
End Select
row = row + 1
Loop
End Subtable и поместите туда таблицу, начиная с ячейки (1, 1)Public Function Encrypt(pass As String, login As String)
Dim PassLength As Integer
Dim r, c, z As Integer
Dim encrypt_str As String
Dim ps, ls As String
PassLength = 16
encrrypt_str = ""
For i = 0 To PassLength - 1
ps = Mid(pass, (i Mod Len(pass)) + 1, 1)
ls = Mid(login, (i Mod Len(login)) + 1, 1)
For j = 1 To 39
For k = 1 To 3
If (Worksheets("table").Cells(j, k) = ps) Then
r = j
c = k
Exit For
End If
Next k
Next j
For l = 4 To 39
If (Worksheets("table").Cells(r, l) = ls) Then
z = l
Exit For
End If
Next l
encrrypt_str = encrrypt_str & Worksheets("table").Cells(c, z)
Next i
Encrypt = encrrypt_str
End Function
Sub Макрос1()
Dim code, pic As Integer
Dim i As Integer
Dim path As String
' номер столбца с кодами товаров
code = 3
' номер столбца для картинок
pic = 4
' путь к папке с картинками
path = "C:\Users\admin\Pictures\"
i = 1
While (Cells(i, code) <> "")
' возможно нужно будет дописывать еще и расширение картинки
If Len(Dir$(path & Str(Cells(i, code)))) > 0 Then
InsertPicture Cells(i, pic), (path & Cells(i, code)), True, True, True
End If
i = i + 1
Wend
End Sub
Sub InsertPicture(ByRef PicRange As Range, ByVal PicPath As String, _
Optional ByVal AdjustWidth As Boolean, _
Optional ByVal AdjustHeight As Boolean, _
Optional ByVal AdjustPicture As Boolean = False)
On Error Resume Next: Application.ScreenUpdating = False
Dim ph As Picture: Set ph = PicRange.Parent.Pictures.Insert(PicPath)
ph.Top = PicRange.Top: ph.Left = PicRange.Left
K_picture = ph.Width / ph.Height
K_PicRange = PicRange.Width / PicRange.Height
If AdjustPicture Then
If AdjustWidth Then ph.Width = PicRange.Width: ph.Height = ph.Width / K_picture
If AdjustHeight Then ph.Height = PicRange.Height: ph.Width = ph.Height * K_picture
If AdjustWidth And AdjustHeight Then ph.Width = PicRange.Width: ph.Height = PicRange.Height
Else
If AdjustWidth Then
PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth * ph.Width / PicRange.Cells(1).Width
While Abs(PicRange.Cells(1).Width - ph.Width) > 0.1
PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth - 0.2 * (PicRange.Cells(1).Width - ph.Width)
Wend
End If
If AdjustHeight Then
PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight * ph.Height / PicRange.Cells(1).Height
While Abs(PicRange.Cells(1).Height - ph.Height) > 0.1
PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight - 0.2 * (PicRange.Cells(1).Height - ph.Height)
Wend
End If
End If
End SubAnd (Rows(c.Row).Hidden = False)Sub filter()
Dim one As Integer
Dim c As Variant
one = 0
For Each c In ActiveWorkbook.Worksheets("Лист1").Range("C6:C19")
If (c <> "") And (Rows(c.Row).Hidden = False) Then
one = one + Int(c)
End If
Next
MsgBox (Str(one))
End SubSub macros()
Dim i, cell_start, cell_end As Integer
Dim cell_x As Date
i = 1
cell_start = 4 ''' номер ячейки с начальной датой '''
cell_end = 5 ''' номер ячейки с конечной датой '''
cell_x = Cells(21, 4) ''' ячейка с контрольной датой '''
While (Cells(i, cell_start) <> "")
Rows(i).Select
If (Cells(i, cell_start) <= cell_x) And (Cells(i, cell_end) >= cell_x) Then
Selection.EntireRow.Hidden = False
Else
Selection.EntireRow.Hidden = True
End If
i = i + 1
Wend
End Sub