见证成长历程---我的答疑解难代码汇总

lsc900707 · 发表于 2017-4-24 18:56

用VBA代码条件求和
http://club.excelhome.net/thread-1341898-1-1.html
(出处: ExcelHome技术论坛)

Sub 收发存汇总()
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Range("o3:r" & Cells(Rows.Count, 18).End(3).Row).ClearContents
Arr = Sheet2.[a1].CurrentRegion
For i = 3 To UBound(Arr)
d(Arr(i, 11)) = d(Arr(i, 11)) + Arr(i, 15)
d1(Arr(i, 11)) = d1(Arr(i, 11)) + Arr(i, 19)
Next
Brr = Sheet3.[a1].CurrentRegion
For i = 3 To UBound(Brr)
d2(Brr(i, 9)) = d2(Brr(i, 9)) + Brr(i, 11)
Next
Crr = [a1].CurrentRegion
For i = 3 To UBound(Crr)
If d.exists(Crr(i, 8)) Then
Cells(i, 15) = d(Crr(i, 8))
Cells(i, 18) = d1(Crr(i, 8))
Cells(i, 16) = d2(Crr(i, 8))
Cells(i, 17) = Cells(i, 14) + Cells(i, 15) - Cells(i, 16)
End If
Next
Application.ScreenUpdating = True
End Sub
Sub 当前库存()
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Range("n3:n" & Cells(Rows.Count, 14).End(3).Row).ClearContents
Arr = Sheet1.[a1].CurrentRegion
For i = 3 To UBound(Arr)
d(Arr(i, 8)) = d(Arr(i, 8)) + Arr(i, 17)
Next
Brr = [a1].CurrentRegion
For i = 3 To UBound(Brr)
If d.exists(Brr(i, 9)) Then
Cells(i, 14) = d(Brr(i, 9))
End If
Next
Application.ScreenUpdating = True
End Sub

复制代码

lsc900707 · 发表于 2017-4-25 22:11

帮忙修改一个数据引用的VB,谢谢v
http://club.excelhome.net/thread-1342252-1-1.html
(出处: ExcelHome技术论坛)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Set wb = GetObject(ThisWorkbook.Path & "\" & "信息.xls")
Set d = CreateObject("scripting.dictionary")
With Workbooks("信息.xls")
      arr = .Sheets(1).UsedRange
      For i = 2 To UBound(arr)
         d(arr(i, 1)) = arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4)
      Next
End With
If d.exists(Target.Value) Then
      s = Split(d(Target.Value), "/")
      Target.Offset(, 1) = s(1)
      Target.Offset(, 2) = s(2)
      Target.Offset(, 3) = s(0)
Else
      MsgBox "对不起，没有此编号！"
End If
Set wb = Nothing
Set d = Nothing
End If
End Sub

lsc900707 · 发表于 2017-4-25 22:13

本帖最后由 lsc900707 于 2017-4-25 22:15 编辑

vba代码多条件求和
http://club.excelhome.net/thread-1342320-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Set d = CreateObject("Scripting.Dictionary")
Range("c2:c" & Cells(Rows.Count, 1).End(3).Row).ClearContents
Arr = Sheet2.[a1].CurrentRegion
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = d(Arr(i, 1)) + Arr(i, 2)
Next
Brr = [a1].CurrentRegion
For i = 2 To UBound(Brr)
Cells(i, 3) = d(Brr(i, 1)) + d(Brr(i, 2))
Next
End Sub

复制代码

lsc900707 · 发表于 2017-4-27 21:12

跨工作簿查询的：
如何用VBA来执行vlookup，是否用find来执行？
http://club.excelhome.net/thread-1342628-1-1.html
(出处: ExcelHome技术论坛)

Sub lsc()
Set wb = GetObject(ThisWorkbook.Path & "" & "时间节点导出20170426214406.xlsx")
Set d = CreateObject("scripting.dictionary")
With Workbooks("时间节点导出20170426214406.xlsx")
arr = .Sheets(1).UsedRange
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
End With
brr = [a1].CurrentRegion
For i = 2 To UBound(brr)
Cells(i, 2) = d(brr(i, 1))
Next
Set wb = Nothing
Set d = Nothing
End Sub

复制代码

lsc900707 · 发表于 2017-4-27 21:14

上一个求助帖子还做了一个工作表事件的，一并贴上来：
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Set wb = GetObject(ThisWorkbook.Path & "\" & "时间节点导出20170426214406.xlsx")
Set d = CreateObject("scripting.dictionary")
With Workbooks("时间节点导出20170426214406.xlsx")
      arr = .Sheets(1).UsedRange
      For i = 2 To UBound(arr)
         d(arr(i, 1)) = arr(i, 2)
      Next
End With
If d.exists(Target.Value) Then
      Target.Offset(, 1) = d(Target.Value)
Else
      MsgBox "对不起，没有此料号！"
End If
Set wb = Nothing
Set d = Nothing
End If
End Sub

lsc900707 · 发表于 2017-4-27 21:18

修改并添加查询代码：

Sub 送检制单()
Application.ScreenUpdating = False
lsc
Dim y As String, Dh As String, T As String, i
y = "SJ" & Format(Now, "yyyymm")
With Sheets("送检制单")
.Range("G3") = y
.Range("C7") = Format(Now, "yyyy/mm/dd hh:mm")
T = Application.WorksheetFunction.Text(.Range("H3"), "000")
Dh = .Range("G3") & T
If .Range("C5") = "" Then
MsgBox "请选择送检人"
End
End If
End With
If Sheets("送检制单").Range("B10").Value = "" Then
MsgBox "请输入零件号"
End
End If
If Sheets("送检制单").Range("E10").Value = "" Then
MsgBox "请输入数量"
End
Else
For i = 10 To 19
If Cells(i, 2) <> "" Then
With Sheets("送检记录")
r = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
.Cells(r, 1) = Range("C7") '发货日期
.Cells(r, 2) = Cells(i, 2) '零件简码
.Cells(r, 3) = Cells(i, 3) '零件名称
.Cells(r, 4) = Cells(i, 4) '图号
.Cells(r, 5) = Cells(i, 5) '送检数量
.Cells(r, 6) = Cells(i, 6) '炉号
.Cells(r, 7) = Cells(i, 7) '批号
.Cells(r, 8) = Cells(i, 8) '供应商
.Cells(r, 9) = Dh '单号
.Cells(r, 10) = Range("C5") '送检人
End With
End If
Next
End If
With Sheets("送检制单")
'.PrintOut Copies:=1
.Range("H3") = T + 1
.Range("C5") = ""
.Range("B10:H19").ClearContents
End With
'ActiveWorkbook.Save
Application.ScreenUpdating = True
'ActiveWorkbook.Close savechanges:=ture
End Sub
Sub lsc()
Set d = CreateObject("Scripting.Dictionary")
arr = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4)
Next
brr = Range("a10:h" & Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(brr)
If d.exists(brr(i, 2)) Then
s = Split(d(brr(i, 2)), "/")
Cells(i + 9, 3) = s(0)
Cells(i + 9, 4) = s(1)
Cells(i + 9, 8) = s(2)
End If
Next
Set d = Nothing
End Sub

复制代码

VBA触发代码范围设置问题
http://club.excelhome.net/thread-1342563-1-1.html
(出处: ExcelHome技术论坛)

lsc900707 · 发表于 2017-4-27 21:20

帮忙修改代码：
录入数据时出现了多余的空行
http://club.excelhome.net/thread-1342581-1-1.html
(出处: ExcelHome技术论坛)

With Sheets("报表数据")
x = .Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 6 To 25 '商品信息分二十行，为了简化代码，使用循环语句
If Cells(i, 2) <> "" Then
.Cells(x + m, 7) = [g4] '制单日期，发料日期
.Cells(x + m, 2) = [j2&k2] '领料字号
.Cells(x + m, 3) = [j3] '物资类别
.Cells(x + m, 4) = Cells(i, 3) '物资名称
.Cells(x + m, 1) = Cells(i, 1) '物资编号
.Cells(x + m, 5) = Cells(i, 5) '规格型号
.Cells(x + m, 6) = Cells(i, 6) '单位
.Cells(x + m, 13) = Cells(i, 7) '数量
.Cells(x + m, 11) = Cells(i, 8) '单价
.Cells(x + m, 14) = Cells(i, 9) '合计金额
.Cells(x + m, 16) = [q2] '出库方式
m = m + 1
End If
Next
End With

复制代码

lsc900707 · 发表于 2017-4-27 21:23

帮忙修改一个数据引用的VB,谢谢v
http://club.excelhome.net/thread-1342252-1-1.html
(出处: ExcelHome技术论坛)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Set wb = GetObject(ThisWorkbook.Path & "\" & "信息.xls")
Set d = CreateObject("scripting.dictionary")
With Workbooks("信息.xls")
      arr = .Sheets(1).UsedRange
      For i = 2 To UBound(arr)
         d(arr(i, 1)) = arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4)
      Next
End With
If d.exists(Target.Value) Then
      s = Split(d(Target.Value), "/")
      Target.Offset(, 1) = s(1)
      Target.Offset(, 2) = s(2)
      Target.Offset(, 3) = s(0)
Else
      MsgBox "对不起，没有此编号！"
End If
Set wb = Nothing
Set d = Nothing
End If
End Sub

lsc900707 · 发表于 2017-4-27 21:26

VBA赋植给多列的问题
http://club.excelhome.net/thread-1342412-1-1.html
(出处: ExcelHome技术论坛)

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.[a2].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 2)) = arr(i, 3) & "/" & arr(i, 4) & "/" & arr(i, 7)
Next
If d.exists(Target.Value) Then
s = Split(d(Target.Value), "/")
Target.Offset(, 1) = s(0)
Target.Offset(, 2) = s(1)
Target.Offset(, 3) = s(2)
Else
MsgBox "对不起，没有此货号！"
End If
Set d = Nothing
End If
End Sub

复制代码

lsc900707 · 发表于 2017-4-27 21:53

本帖最后由 lsc900707 于 2017-4-27 21:54 编辑

有条件的复制
http://club.excelhome.net/thread-1342742-1-1.html
(出处: ExcelHome技术论坛)

Private Sub CommandButton1_Click()
Dim brr(1 To 1000, 1 To 4)
For Each sht In Worksheets
If sht.Name = Trim(TextBox1.Text) Then
Worksheets(sht.Name).Select
End If
Next
arr = Sheet4.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 7) <> 1 Then
k = k + 1
For j = 1 To 4
brr(k, j) = arr(i, j)
Next
End If
Next
If k = 0 Then
MsgBox "没有找到相关数据！"
Else
ActiveSheet.[a2:d1000].ClearContents
ActiveSheet.[a2].Resize(k, 4) = brr
End If
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[分享] 见证成长历程---我的答疑解难代码汇总

评分

评分

评分

评分

最新热点 /1