Private Sub CommandButton3_Click()
Dim ctl As Control
For Each ctl In Me.Controls
If InStr(ctl.Name, "TextBox") Then
If Len(ctl.Text) = 0 Then ctl.Value = 0
End If
Next ctl
End
Лучше изменить имена текстбоксов, например: Tbx1, Tbx2, и т.д.,- чтобы не перебирать все контролы, а только Tbx
кол-во писем до 01.10.17 =СЧЁТЕСЛИ(C2:L2;"<"&A2) кол-во писем с опозданием до 10 дней =СЧЁТЕСЛИМН(C2:L2;">"&A2;C2:L2;"<"&A2+10) кол-во писем с опозданием более 10 дней =СЧЁТЕСЛИ(C2:L2;">="&A2+10)
Sub ertert()
Dim x, bz, y(), i&, j&, k&
x = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
bz = Range("E2:F" & Cells(Rows.Count, 5).End(xlUp).Row).Value
ReDim y(1 To UBound(x) * UBound(bz), 1 To 3)
For i = 2 To UBound(bz)
For j = 2 To UBound(x)
k = k + 1
y(k, 1) = x(j, 1)
y(k, 2) = bz(i, 1)
y(k, 3) = bz(i, 2)
Next j
Next i
Range("H3").Resize(k, 3).Value = y()
End Sub
Sub ertert()
Dim x, i&, j&, s$
With Range("A1").CurrentRegion
x = .Value
For i = 1 To UBound(x)
If x(i, 1) <> s Then
s = x(i, 1)
j = i
Else
x(j, 2) = x(j, 2) & ", " & x(i, 2)
x(i, 1) = "": x(i, 2) = ""
End If
Next i
.Value = x
End With
End Sub
Sub ertert()
Dim x, s$, i&, k&
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
x = .Value
For i = 1 To UBound(x)
If Len(x(i, 1)) Then
s = x(i, 1): k = 0
Else
k = k + 1
x(i, 1) = s & "-" & k
End If
Next i
.Value = x
End With
End Sub
With Range("A2").CurrentRegion.Resize(, 3).Offset(2)
.ClearContents' очищаем диапазон перед вставкой данных
If k > 0 Then .Resize(k).Value = y()
End With
Если данные расположены так, как в примере (первые 2 строки - заголовки, данные начинаются с 3-й строки), то должно работать.
Судя по примеру, вот так должно работать (в стандартный модуль):
Код
Sub ttt()
Dim wsh As Worksheet
With Application
.DisplayAlerts = False
For Each wsh In ThisWorkbook.Sheets
If InStr(wsh.Name, "_") Or InStr(wsh.Name, "!") Then wsh.Delete
Next wsh
.DisplayAlerts = True
End With
End Sub
suigres, привет попробуйте так (в модуль листа "report")
Код
Private Sub ComboBox1_Change()
Dim x, y(), i&, s$, k&
If Me.ComboBox1.ListIndex = -1 Then Exit Sub
x = Sheets("data").Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To 3)
s = Me.ComboBox1.Value
For i = 2 To UBound(x)
If x(i, 4) = s Then
k = k + 1
y(k, 1) = x(i, 1) 'HouseID
y(k, 2) = x(i, 2) 'Адрес
y(k, 3) = x(i, 3) 'Клиентов
End If
Next i
With Range("A2").CurrentRegion.Offset(2)
.ClearContents
If k > 0 Then .Resize(k).Value = y()
End With
End Sub
Function VidD(rOtm As Range, rVid As Range) As String
Dim x, y, j&, s$
x = rOtm.Value
y = rVid.Value
For j = 1 To UBound(x, 2)
If Len(x(1, j)) Then s = s & ", " & y(1, j)
Next j
VidD = Mid(s, 3)
End Function
Private Sub CommandButton1_Click()
Dim x, i&
x = Sheets("Расход").Range("A1:A10").Value 'данные в массив
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x)
.Item(x(i, 1)) = 1
Next i
' в столбик
[A1].Resize(.Count).Value = Application.Transpose(.keys)
' в строку
[B1].Resize(, .Count).Value = .keys
End With
End Sub
Sub ertert()
Dim x, i&, v
x = Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
For Each v In Split(x(i, 1), ",")
.Item(v) = Empty
Next v
Next i
Range("A23").Resize(.Count).Value = Application.Transpose(.keys)
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C2").CurrentRegion.Columns(3).Resize(, 3)) Is Nothing Then Exit Sub
With Sheets("Лист2")
.Range("E3").Value = Cells(Target.Row, 3).Value
.Range("I3").Value = Cells(2, Target.Column).Value
.Activate
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("C2").CurrentRegion.Columns(3).Resize(, 3)) Is Nothing Then Exit Sub
With Sheets("Лист2")
.Cells(Rows.Count, 5).End(xlUp)(2, 1).Value = Cells(Target.Row, 3).Value
.Cells(Rows.Count, 9).End(xlUp)(2, 1).Value = Cells(2, Target.Column).Value
End With
End Sub
Sub ertert()
Dim magz As Range, b As Range, poisk As Range, r As Range
Dim i As Long, l As Long
'Список самих магазинов, искомые значения:
Set magz = Range([a1], Cells(Rows.Count, 1).End(xlUp))
'Поисковый столбец, в котором ищем значения определенных магазинов:
Set poisk = Range([e1], Cells(Rows.Count, 5).End(xlUp))
poisk.Font.ColorIndex = xlAutomatic: magz.Font.ColorIndex = xlAutomatic
With CreateObject("VBScript.RegExp")
.Global = True: .IgnoreCase = True
For Each b In magz.Cells
.Pattern = b.Value: l = 5
For Each r In poisk.Cells
If .Test(r) Then
b.Font.Color = vbBlue
With .Execute(r)
For i = 0 To .Count - 1
'совпадения выделяем красным
r.Characters(.Item(i).FirstIndex + 1, l + 1).Font.Color = vbRed
Next
End With
End If
Next r
Next b
End With
End Sub
Sub ertert()
Dim a, x, i As Long, j As Long, temp$
a = Range("A7").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a)
.Item(CStr(a(i, 3))) = 0 'По договору №
Next i
x = Sheets("Расход").Range("A1").CurrentRegion.Value
For i = 2 To UBound(x) 'отбираем данные расхода
If x(i, 7) <> "В" Then
temp = Split(x(i, 2), "|")(1) 'договор
If .exists(temp) Then .Item(temp) = .Item(temp) + x(i, 4) 'Кол-во расход
End If
Next i
x = Sheets("Приход").Range("A1").CurrentRegion.Value
For i = 2 To UBound(x) 'отбираем данные прихода
temp = CStr(x(i, 2))
If .exists(temp) Then
.Item(temp) = .Item(temp) * x(i, 9) 'кол-во*цену
End If
Next i
For i = 2 To UBound(a)
If a(i, 4) <> .Item(CStr(a(i, 3))) Then MsgBox "Не сходится по дог. " & _
a(i, 3) & ": " & a(i, 4) & " и " & .Item(CStr(a(i, 3))), 64
Next i
Range("G8").Resize(.Count).Value = Application.Transpose(.items)
End With
End Sub
Располагайте коды в стандартных модулях (не модулях листов)
Формулка не слишком тяжелая, на несколько тыс строк, по идее, должна работать. Попробуйте, возможно подойдет. По поводу "Оптимизация или нет". Нет, это другой код, хотя и похожий.