Sub 保存()If Application.WorksheetFunction.CountIf(Sheets("DATA").Range("h:h"), Sheets("入库单").[b2]) > 0 Then MsgBox "亲,您已经保存过了!" End End IfSet conn = CreateObject("adodb.connection")Set rs = CreateObject("adodb.recordset")ctr = "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.Path & "\出入库系统.xls"conn.Open ctrFor j = 4 To Sheets("入库单").[a65536].End(xlUp).Row If WorksheetFunction.CountA(Sheets("入库单").Range("a" & j & ":g" & j)) <> 7 Then MsgBox "第" & j - 3 & "行信息没有填写完整!" EndEnd If Next j For i = 4 To Sheets("入库单").[a65536].End(xlUp).Row With Sheets("入库单") Sqls = "insert into [DATA$] (编码,品名,单位,单价,数量,金额,备注,单号,日期,开单人) values" & _ "('" & .Cells(i, 1) & "','" & .Cells(i, 2) & "','" & .Cells(i, 3) & "','" & .Cells(i, 4) & "'," & .Cells(i, 5) & ",'" & .Cells(i, 4) * .Cells(i, 5) & "','" & .Cells(i, 7) & "','" & .Cells(2, 2) & "','" & .Cells(2, 5) & "','" & .Cells(2, 7) & "')" End Withconn.Execute Sqls Next i MsgBox "保存成功!" conn.CloseEnd Sub
ä¸ãæ°æ®ééç³»ç»åè½ å½å ¥ãä¿åãæ¥è¯¢ãæ¸ ç©ºãä¿®æ¹
äºã两个çé¢
1.æ°æ®å½å ¥çé¢ï¼åå°åè½ä½¿ç¨çé¢ï¼å®ç°âå½å ¥ãä¿åãæ¥è¯¢ãæ¸ ç©ºãä¿®æ¹âï¼
2. æ°æ®åå¨çé¢ï¼åå°å®ç°æ°æ®çä¿åï¼ å½å ¥çé¢ï¼
ä¸ãå®ç°æ¹æ³ 1. ä¿ååè½ Sub Save() '
'ä¿åæ°æ® Marcoï¼xiaohouå¶ä½ï¼æ¶é´2013-9-5 '
Dim r1, r2, r3 As Range With Sheets("æ°æ®åå¨")
Set r2 = .Range("a2", .[a100000].End(xlUp)) End With
With Sheets("æ°æ®å½å ¥") Set r1 = .Range("c4:e4, d6:l39")
If IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then 'Or IsEmpty(.Range("b7:b41")) æ·»å ç§å®¤ä¸ä¸ºç©ºï¼æªæå MsgBox ("ç¼ç ãå称为空ï¼ä¸å¯ä¿åï¼") Else
Set r3 = r2.Find(.Cells(4, 3), , , 1) If Not r3 Is Nothing Then
MsgBox ("æ¤ç¼ç å·²åå¨ï¼ä¸å¯ä¿åãå¦ææ¤ä¿¡æ¯éè¦ä¿®æ¹ï¼è¯·ç¹å»æ¥è¯¢ååä¿®æ¹")
Else
Sheets("æ°æ®åå¨").Rows("2:35").Insert Shift:=xlDown
.Range("c6:l39").Copy 'å¤å¶âæ°æ®å½å ¥â表ä½ä¿¡æ¯
Sheets("æ°æ®åå¨").Range("c2:l2").PasteSpecial Paste:=xlPasteValues .Range("c4").Copy 'å¤å¶âæ°æ®å½å ¥âç¼ç
Sheets("æ°æ®åå¨").Range("a2:a35").PasteSpecial Paste:=xlPasteValues .Range("e4").Copy 'å¤å¶âæ°æ®å½å ¥âå称
Sheets("æ°æ®åå¨").Range("b2:b35").PasteSpecial Paste:=xlPasteValues r1.ClearContents 'ä¿åæ°æ®åï¼æ¸ 空å½å ¥çé¢
.Range("c4").Select End If End If End With End Sub
2. æ¥è¯¢åè½ Sub Query() '
' æ¥è¯¢çé Macroï¼xiaohouå¶ä½ï¼æ¶é´2013-9-5 ' '
Dim Erow As Integer Dim r1, r2 As Range With Sheets("æ°æ®å½å ¥") Set r1 = .Range("d6:l39") Set r2 = .Range("a6:b39")
Erow = Sheets("æ°æ®åå¨").[a100000].End(xlUp).Row
r1.ClearContents
'For Each ce In .[a2:x2]
'If ce <> "" Then ce.Value = "*" & ce & "*" 'å ä¸éé 符*,å®ç°æ¨¡ç³æ¥è¯¢
'Next
If IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then
'Or IsEmpty(.Range("b7:b41")) æ·»å ç§å®¤ä¸ä¸ºç©ºï¼æªæå
MsgBox ("ç¼ç ãå称为空ï¼ä¸å¯æ¥è¯¢ï¼") Else
Sheets("æ°æ®åå¨").Range("A1:l" & Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _ .[c3:e4], CopyToRange:=.[A5:l5], Unique:=False
r2.Borders(xlDiagonalDown).LineStyle = xlNone r2.Borders(xlDiagonalUp).LineStyle = xlNone
r2.Borders(xlEdgeLeft).LineStyle = xlNone
r2.Borders(xlEdgeTop).LineStyle = xlNone
r2.Borders(xlEdgeBottom).LineStyle = xlNone
'r2.Borders(xlEdgeRight).LineStyle = xlNone r2.Borders(xlInsideVertical).LineStyle = xlNone
r2.Borders(xlInsideHorizontal).LineStyle = xlNone
r2.NumberFormatLocal = ";;;"
'For Each ce In .[a2:x2]
'If ce <> "" Then ce.Value = Mid(ce, 2, Len(ce) - 2) 'åæ¶ "*"éé 符
'Next End If End With End Sub
3. æ´æ° Sub Update() '
'æ´æ° Macroï¼xiaohouå¶ä½ï¼æ¶é´2013-9-5
Dim arr, d As Object
Dim r As Range
Dim lr&, i&, j%
With Sheets("æ°æ®å½å ¥") 'æ¥è¯¢ä¿®æ¹å·¥ä½è¡¨æ°æ®åºååå ¥æ°ç»arr
'arr = .Range("A7:D" & .Range("A65536").End(xlUp).Row)
arr = .Range("a6:l39")
Set r = .Range("d6:l39")
End With
Set d = CreateObject("scripting.dictionary") 'å®ä¹åå ¸å¯¹è±¡
For i = 1 To UBound(arr) 'éè¡
'If Len(arr(i, 2)) <> 0 Then 'æåºâå计âè¡ï¼å³ï¼å§åå¡æ°æ®
If Not d.exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) Then d(arr(i, 1) & arr(i, 2) & arr(i, 3)) = arr(i, 4) & Chr(9) & arr(i, 5) _
& Chr(9) & arr(i, 6) & Chr(9) & arr(i, 7) & Chr(9) & arr(i, 8) & Chr(9) & arr(i, 9) & Chr(9) & arr(i, 10) & Chr(9) & arr(i, 11) & Chr(9) & arr(i, 12)
'ä¸ä¸å¥ï¼å¦æç¼ç åå称è¿æ¥å符串åå ¸ä¸åå¨(é¦æ¬¡åºç°ï¼è¿éå¤æå¯è½å¤ä½)ï¼è¿ä¸ªå符串添å å°åå ¸é®å¼ï¼åç»çç¸å ³å±æ§å段ç¨å¶è¡¨ç¬¦è¿æ¥æ·»å å°åå ¸æ¡ç®
'End If Next
With Sheets("æ°æ®åå¨")
lr = .Range("A100000").End(xlUp).Row 'æ°æ®åå¨å·¥ä½è¡¨æ°æ®è¡æ°
'.Range("C2:D" & lr).SpecialCells(xlCellTypeConstants, 23).ClearContents 'æ¸ é¤CãDåä¸å«å ¬å¼åå æ ¼çå¼
arr = .Range("A2:l" & lr) 'æ°æ®åå¨å·¥ä½è¡¨æ°æ®åºååå ¥æ°ç»arr
For i = 1 To UBound(arr) 'éè¡
If d.exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) Then 'å¦æç¼ç åå称è¿æ¥å符串åå ¸åå¨ï¼å³Sheet2ä¸æ
For j = 4 To 12 'DãEãF...åéå
'If Not Cells(i, j).HasFormula Then Cells(i, j) = Split(d(arr(i, 1) & arr(i, 2)), Chr(9))(j - 3)
'ä¸å¥ï¼å¦æåå æ ¼ä¸å«å ¬å¼ï¼æSheet2对åºçæ°æ®åå ¥è¿ä¸ªåå æ ¼
.Cells(i + 1, j) = Split(d(arr(i, 1) & arr(i, 2) & arr(i, 3)), Chr(9))(j - 4)
Next
End If
Next
End With
r.ClearContents
Sheets("
æ°æ®å½å ¥
").Cells(4, 3).Select
MsgBox ("
æ°æ®å·²æ´æ°å®æï¼è¥è¦æ¥çæ´æ°åçå 容ï¼è¯·ç¹å»æé®æ¥è¯¢")