|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
有中文的代码
- Private Sub Worksheet_Change(ByVal Target As Range)
- If Target.Count > 1 Then Exit Sub
- If (Target.Column <> 3 And Target.Column <> 4) Or (Target.Row < 11 And Target.Row > 15) Then Exit Sub
- If Target.Value < 1 And Target.Value > 0 Then
- If Target.Column = 3 Then
- If Target.Offset(0, 1) <> "" Then
- If Target < Target.Offset(0, 1) Then
- MsgBox "請確認" & Target.Address & "資訊是否為有效值?"
- Application.EnableEvents = False
- Target = ""
- End If
- End If
- Else
- If Target.Offset(0, -1) <> "" Then
- If Target > Target.Offset(0, -1) Then
- MsgBox "請確認" & Target.Address & "資訊是否為有效值?"
- Application.EnableEvents = False
- Target = ""
- End If
- End If
- End If
- Else
- MsgBox "請確認" & Target.Address & "資訊是否為有效值?"
- Application.EnableEvents = False
- Target = ""
- End If
- Application.EnableEvents = True
- End Sub
- Sub jzfx()
- Dim cel As Range, col%, x, i&, y, j&, Brr, ii&, jj&, ks, js, aa
- Dim d1, k1, t1
- Set d1 = CreateObject("Scripting.Dictionary")
- Sheet11.Activate
- ActiveSheet.Calculate
- Application.Calculation = xlManual
- n = Application.CountA(Sheet11.[h2:k11])
- If n = 0 Then MsgBox "請在H2:K11選填產業名或關鍵字": Exit Sub
- Brr = [h2:k11]
- n = 17: [e19:en999] = ""
- For i = 1 To UBound(Brr)
- For j = 1 To 4
- If Brr(i, j) <> "" Then
- If j <> 4 Then
- For ii = 0 To UBound(k(j))
- If Brr(i, j) = k(j)(ii) Then
- t(j)(ii) = Left(t(j)(ii), Len(t(j)(ii)) - 1)
- x = Split(t(j)(ii), "*")
- For jj = 0 To UBound(x)
- d1(x(jj)) = d1(x(jj)) + 1
- If d1(x(jj)) = 33 Then GoTo 100
- Next
- End If
- Next
- Else
- For ii = 1 To UBound(Arr)
- If InStr(Arr(ii, 11), Brr(i, j)) Then
- y = Arr(ii, 1) & "|" & Arr(ii, 2) & "|" & Arr(ii, 8) & "|" & Arr(ii, 9) & "|" & Arr(ii, 10)
- d1(y) = d1(y) + 1
- If d1(y) = 33 Then GoTo 100
- End If
- Next
- End If
- End If
- Next
- Next
- 100:
- k1 = d1.keys
- For jj = 0 To UBound(k1)
- y = Split(k1(jj), "|")
- n = n + 1
- Cells(n, 5) = n - 17
- Cells(n, 6).Resize(1, 5) = y
- Next
- Call ndfx
- Call afa
- Application.ScreenUpdating = True
- CommandButton1.Visible = False
- CommandButton2.Visible = True
- ActiveSheet.Protect
- MsgBox "OK"
- End Sub
复制代码 |
|