|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
原帖由 chenermei 于 2011-3-26 09:15 发表 
我是新手,VBA未还学过,请指教宏代码?能发个抓图吗?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim cn As New ADODB.Connection
Dim lastrow As Integer
Dim mingchen As String
Dim i As Integer
Dim j As Integer
Dim y As Integer
Dim p As Integer
Application.ScreenUpdating = False
With Worksheets("辅助表")
.Cells.ClearContents
.Range("A1:B1") = Split("名称 型号")
cn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= " & ThisWorkbook.FullName
Sql = "select distinct 名称 from [sheet2$]"
.[a1].CopyFromRecordset cn.Execute(Sql)
.Cells(1, 1).Value = "名称"
cn.Close
Set cn = Nothing
lastrow = .[A65536].End(xlUp).Row
.Range("a2:a" & lastrow).Name = "名称"
Set rng = [A65536]
For i = 2 To lastrow
mingchen = .Cells(i, 1).Value
p = 0
x = Application.WorksheetFunction.CountIf(Columns("A"), mingchen)
For j = 1 To x
Set rng = Columns("A").Find(mingchen, rng, xlValues, xlWhole, xlByColumns)
huohao = rng.Offset(0, 1).Text
y = Application.WorksheetFunction.CountIf(.Rows(i), huohao)
If y < 1 Then
.Cells(i, j + 1 + p) = huohao
Else
p = p - 1
End If
Next j
.Range(.Cells(i, 2), .Cells(i, j + 1 + p)).Name = mingchen
Next i
End With
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ps As String
If Target.Column = 6 And Target.Row > 1 And Target.Count = 1 Then
ps = Target.Value
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=" & ps
End With
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 6 And Target.Count = 1 And Target.Row > 1 Then
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=名称"
End With
End If
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-3-26 08:56
发表于 2011-3-26 09:09
楼主
