请帮优化一下函数的位置，位置调试多次都还是不行

阿腊

帮我修改一下vba代码对应的行列位置，位置自己调试都还不行，请老师帮忙一下，谢谢！！！！！

小書生

调整哪里？那一段代码？是你写的吗？作者改一下不就好了

阿腊

小書生 发表于 2023-2-1 14:01
调整哪里？那一段代码？是你写的吗？作者改一下不就好了

不是我写的，我修改成自己想要模板。但是位置自己不会调

阿腊

小書生 发表于 2023-2-1 14:01
调整哪里？那一段代码？是你写的吗？作者改一下不就好了

就是位置调试还是不行

小書生

1. Sub 保存() '已改
   
2.     Dim arr, brr()
   
3.     If Range("c4") = "" Or Range("j3") = "" Or Range("j2") = "" Or Range("c5") = "" Or Range("c6") = "" Or Range("e6") = "" Then
   
4.         MsgBox "表头填写不完整！"
   
5.        ' Exit Sub
   
6.     End If
   
7.     If Range("h15") = 0 Then
   
8.         MsgBox "正表中数据不全不能保存！"
   
9.        ' Exit Sub
   
10.     End If
    
11.     r = Application.CountA(Sheet1.Range("b8:b14"))
    
12.     arr = Range("b8:j" & r + 7)
    
13.     ReDim brr(1 To r, 1 To 14)
    
14.     For i = 1 To r
    
15.         brr(i, 1) = Range("j3")
    
16.         brr(i, 2) = Range("j2")
    
17.         brr(i, 3) = Range("c4")
    
18.         brr(i, 12) = Range("j17")
    
19.         brr(i, 13) = Range("j16")
    
20.         brr(i, 14) = Range("j6")
    
21.         For j = 1 To 8
    
22.         If j > 1 Then a = j + 1 Else a = j
    
23.            brr(i, j + 3) = arr(i, a)
    
24.         Next
    
25.     Next
    
26.     With Sheets("送货记录")
    
27.         Set c = Sheets("送货记录").Range("b:b").Find(Range("j2"), , , , , 1)
    
28.         If c Is Nothing Then
    
29.             i = .Range("c65536").End(3).Row + 1
    
30.             n = IIf(i = 4, 3, i)
    
31.             .Cells(n, 1).Resize(r, 14) = brr
    
32.         Else
    
33.             MsgBox "单据号为：" & Range("j2") & "的销售单信息已经保存，不能重复！"
    
34.             Exit Sub
    
35.         End If
    
36.     End With
    
37.     MsgBox "OK！保存成功！"
    
38. End Sub

复制代码

1. Sub 删除() '删除  已经修改
   
2.     Application.ScreenUpdating = False
   
3.     Dim Msg&, r&, K&
   
4.     Dim hm, c As Range, c2 As Range
   
5.     hm = Range("J2")
   
6.     With Sheets("送货记录")
   
7.         Set c = Sheets("送货记录").Range("b:b").Find(hm, , , , , 1)
   
8.         If Not c Is Nothing Then
   
9.             Msg = MsgBox("确认要删除单据为" & Range("J2").Value & "的已入库信息吗？删除后将不可恢复！！", vbYesNo)
   
10.             If Msg = vbNo Then Exit Sub
    
11.             Set c2 = Sheets("送货记录").Range("b:b").Find(hm, , , , , 2)
    
12.             r = c.Row
    
13.             K = c2.Row
    
14.             .Range("a" & r & ":n" & K).Delete        '删除
    
15.         End If
    
16.     End With
    
17.     Application.ScreenUpdating = True
    
18.     Application.EnableEvents = True
    
19.     MsgBox "已成功删除了单据号为：" & hm & "的信息！"
    
20. End Sub

复制代码

1. Sub 查找() '已修改
   
2.     Dim arr, brr(), Msg&, tr&
   
3.     Dim hm, c As Range, c2 As Range
   
4.     Dim r&, K&, n&, b&, j&
   
5.     If Range("J2") = "" Then MsgBox "你未输入单据号!": Exit Sub
   
6.     hm = Range("J2")
   
7.     With Sheets("送货记录")
   
8.         Set c = Sheets("送货记录").Range("b:b").Find(hm, , , , , 1)
   
9.         If Not c Is Nothing Then
   
10.             Set c2 = Sheets("送货记录").Range("b:b").Find(hm, , , , , 2)
    
11.             r = c.Row      '开始行号
    
12.             K = c2.Row     '结束行号
    
13.             arr = .Range("a" & r & ":n" & K)
    
14.         Else
    
15.             MsgBox "没有找到" & hm & "的销售单信息"
    
16.             Exit Sub
    
17.         End If
    
18.     End With
    
19.     Range("a8:j14") = ""
    
20.     Range("c4") = arr(1, 3)
    
21.     Range("j3") = arr(1, 1)
    
22.     Range("j17") = arr(1, 12)
    
23.     Range("j16") = arr(1, 13)
    
24.     Range("j6") = arr(1, 14)
    
25.     For i = 1 To UBound(arr)
    
26.         Cells(i + 7, 1) = i
    
27.         For j = 2 To 9
    
28.   If j > 2 Then a = j + 1 Else a = j
    
29.             Cells(i + 7, a) = arr(i, j + 2)
    
30.         Next
    
31.     Next
    
32.     With Sheets("客供资料")
    
33.         Set c = Sheets("客供资料").Range("a:a").Find(Range("c4"), , , , , 1)
    
34.         If Not c Is Nothing Then
    
35.             r = c.Row
    
36.             Range("c5") = .Cells(r, 3) '地址
    
37.             Range("c6") = .Cells(r, 4) '联系人
    
38.             Range("e6") = .Cells(r, 5) '电话
    
39.         End If
    
40.     End With
    
41.     MsgBox "OK！"
    
42. End Sub

复制代码

小書生

还是给你扔上来吧！


另外，建议去学一下基本的vba、表格知识；


还有，这是函数版块，你发帖发错地方了，有vba版块！！

阿腊

小書生 发表于 2023-2-1 16:52
还是给你扔上来吧！

好的，万分感谢你

阿腊

小書生 发表于 2023-2-1 16:52
还是给你扔上来吧！

你好，下拉窗体第一行如何固定？

阿腊

小書生 发表于 2023-2-1 16:52
还是给你扔上来吧！

'============双击列表项录入到工作表
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If Me.ListBox1.ListIndex = 0 Then Exit Sub  '列表框第一行选不中
    ActiveCell.Offset(0, -1) = ActiveCell.Row() - 7
    For i = 1 To 7
        ActiveCell.Offset(0, i - 1) = Me.ListBox1.List(Me.ListBox1.ListIndex, i - 1)
    Next
    Unload Me
End Sub

'=================模糊查找生成列表
Private Sub TextBox1_Change()
    Dim s As String, j&, n&, x&
    Dim brr()
'   Call zb
    s = TextBox1.Text
    With ListBox1
        If TextBox1.Value <> "" Then
            ReDim brr(1 To UBound(arr), 1 To 6)
            For i = 1 To UBound(arr)
                If arr(i, 1) Like "*" & s & "*" Or arr(i, 2) Like "*" & s & "*" Or arr(i, 3) Like "*" & s & "*" Or arr(i, 4) Like "*" & s & "*" Or arr(i, 5) Like "*" & s & "*" Then
                    n = n + 1
                    For j = 1 To 6
                        brr(n, j) = arr(i, j)
                    Next
                End If
            Next i
            .List = brr
        Else
            .List = arr
        End If
    End With
End Sub


'==============初始化
Private Sub UserForm_Initialize()
    Dim K, d
    Set d = CreateObject("Scripting.Dictionary")
    Set Sht1 = Worksheets("产品信息表")
    Myr = Sht1.[A65536].End(xlUp).Row
    arr = Sht1.Range("a1:H" & Myr)
    With Me.ListBox1
        .ColumnCount = 7
        .ColumnWidths = "100,50,60,60,50,70"
        .BoundColumn = 1
        .List = arr
    End With
End Sub