vba单据查询系统代码有误

富之宝

当我查退费时只查到一条记录,明明里面有两条记录啊,以下为查询代码
Private Sub CommandButton1_Click()
Sheets("费用查询结果表").Rows("2:9999").ClearContents '清除之前的筛选结果
Sheets("费用查询结果表").Visible = True
Sheets("费用查询结果表").Activate
For i = 0 To 费用项目.ListCount - 1
    If 费用项目.Selected(i) Then '如果项目被选择
        With Sheets("费用记录")
            Set rng = .Rows(1).Find(费用项目.List(i), , , xlWhole) '查找到项目所在单元格
            Set rng1 = .Rows(1).Find(费用项目.List(i), , , xlWhole) '同上，赋给另一个变量
            Do Until rng.End(xlDown).Value = "" '向下定位到的单元格为空则退出
                Set erng = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '定位复制到的目标单元格位置
                Set rng = rng.End(xlDown) '将单元格定位后向赋给自己
                rng.EntireRow.Range("a1:c1").Copy erng
                erng.Offset(0, 3) = rng1
                erng.Offset(0, 4) = rng
                erng.Offset(0, 5) = rng.EntireRow.Range("l1")
                rng.EntireRow.Range("m1:p1").Copy erng.Offset(0, 6)
            Loop
        End With
    End If
Next
End Sub

Private Sub UserForm_Initialize()
For Each a In Array("保教费", "接送费", "伙食费", "退费", "被子", "书包", "校服")
Me.费用项目.AddItem a
Next
End Sub

苍海拾贝

有问题的语句:
Do Until rng.End(xlDown).Value = "" '向下定位到的单元格为空则退出
红色部分直接取最后一行了，中间的行都忽略了，当然只显示一条记录了，建议加个变量，循环取数
。。。。。。。。。
i = 1
            Do Until rng.Offset(i, 0).Value = "" ' 向下定位到的单元格为空则退出
                Set erng = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '定位复制到的目标单元格位置
                rng.Offset(i, 0).EntireRow.Range("m1:p1").Copy erng.Offset(0, 6)
                rng.Offset(i, 0).EntireRow.Range("a1:c1").Copy erng
                erng.Offset(0, 3) = rng1
                erng.Offset(0, 4) = rng.Offset(i, 0)
                erng.Offset(0, 5) = rng.Offset(i, 0).EntireRow.Range("l1")
                i = i + 1
            Loop
。。。。。。。。。。。。。。。

富之宝

苍海拾贝 发表于 2013-12-8 20:15
有问题的语句:
Do Until rng.End(xlDown).Value = "" '向下定位到的单元格为空则退出
红色部分直接取最后 ...

我要再上图选择查询，我把代码修改成你那样后，运行没结果
Private Sub CommandButton1_Click()
Sheets("费用查询结果表").Rows("2:9999").ClearContents '清除之前的筛选结果
Sheets("费用查询结果表").Visible = True
Sheets("费用查询结果表").Activate
For i = 0 To 费用项目.ListCount - 1
    If 费用项目.Selected(i) Then '如果项目被选择
        With Sheets("费用记录")
            Set rng = .Rows(1).Find(费用项目.List(i), , , xlWhole) '查找到项目所在单元格
            Set rng1 = .Rows(1).Find(费用项目.List(i), , , xlWhole) '同上，赋给另一个变量
            i = 1
            Do Until rng.Offset(i, 0).Value = "" '向下定位到的单元格为空则退出
                Set erng = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '定位复制到的目标单元格位置
                'Set rng = rng.End(xlDown) '将单元格定位后向赋给自己
                rng.Offset(i, 0).EntireRow.Range("m1:p1").Copy erng.Offset(0, 6)
                rng.Offset(i, 0).EntireRow.Range("a1:c1").Copy erng
                rng.EntireRow.Range("a1:c1").Copy erng
                erng.Offset(0, 3) = rng1
                erng.Offset(0, 4) = rng.Offset(i, 0)
                erng.Offset(0, 5) = rng.Offset(i, 0).EntireRow.Range("l1")
                'rng.EntireRow.Range("m1:p1").Copy erng.Offset(0, 6)
                i = i + 1
            Loop
        End With
    End If
Next
End Sub

苍海拾贝

上个附件吧，楼主，看不到完整的代码
这是我自己模拟的测试，运行没有问题，供参考

富之宝

苍海拾贝 发表于 2013-12-8 21:15
上个附件吧，楼主，看不到完整的代码
这是我自己模拟的测试，运行没有问题，供参考

好的,我就上传 开票 系统.rar (31.25 KB, 下载次数: 10)

2013-12-8 21:39 上传

点击文件名下载附件

还是不行，你看原文件吧,还在学习,一步一步的做，希望指导,谢谢!

苍海拾贝

富之宝 发表于 2013-12-8 21:41
好的,我就上传还是不行，你看原文件吧,还在学习,一步一步的做，希望指导,谢谢!

在你的附件基础上进行了修改。看看是否这样？
开票 系统.rar (26.81 KB, 下载次数: 17)

2013-12-8 22:05 上传

点击文件名下载附件

富之宝

苍海拾贝 发表于 2013-12-8 22:05
在你的附件基础上进行了修改。看看是否这样？

不行,还是谢谢你的帮助,问题很大

富之宝

苍海拾贝 发表于 2013-12-8 22:46
对于中间有空行的，也要进行处理，改写一下

谢谢你的回复,我找到我原来的问题了,原来是数据源格式问题,我最开始的代码没问题

苍海拾贝

富之宝 发表于 2013-12-8 22:16
不行,还是谢谢你的帮助,问题很大

对于中间有空行的，也要进行处理，改写一下

1. Private Sub CommandButton1_Click()
   
2.     Sheets("费用查询结果表").Rows("2:9999").ClearContents    '清除之前的筛选结果
   
3.     Sheets("费用查询结果表").Visible = True
   
4.     Sheets("费用查询结果表").Activate
   
5.     For I = 0 To 费用项目.ListCount - 1
   
6.         If 费用项目.Selected(I) Then    '如果项目被选择
   
7.             With Sheets("费用记录")
   
8.                 Set rng = .Rows(1).Find(费用项目.List(I), , , xlWhole)    '查找到项目所在单元格
   
9.                 Set rng1 = rng    '同上，赋给另一个变量
   
10.                 I = 1   
    
11.                 Do Until I > .Cells(Rows.Count, 1).End(3).Row    '向下定位到的单元格为空则退出
    
12.                     If rng.Offset(I, 0).Value <> "" Then
    
13.                         Set erng = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)    '定位复制到的目标单元格位置
    
14.                         rng.EntireRow.Range("a1:c1").Copy erng
    
15.                         erng.Offset(0, 3) = rng1
    
16.                         erng.Offset(0, 4) = rng.Offset(I, 0)
    
17.                         erng.Offset(0, 5) = rng.Offset(I, 0).EntireRow.Range("l1")
    
18.                         rng.EntireRow.Range("m1:p1").Copy erng.Offset(0, 6)
    
19.                     End If
    
20.                     I = I + 1   
    
21.                 Loop
    
22.             End With
    
23.         End If
    
24.     Next
    
25. End Sub

复制代码

[url=]Close[/url]

[url=]Close[/url]

富之宝

苍海拾贝 发表于 2013-12-8 22:46
对于中间有空行的，也要进行处理，改写一下

请帮再修改个复制的代码好吗? 谢谢 !
Sub copyadd()
    Application.ScreenUpdating = False
    On Error Resume Next
    Dim i As Integer, sht As Worksheet
    If Sheets("汇总表") Is Nothing Then
       yn = MsgBox(prompt:="找不到《汇总表》,要新建一个吗?", Buttons:=vbYesNo + vbQuestion)
          If yn = vbYes Then
             Worksheets.Add after:=Worksheets(Worksheets.Count)
             ActiveSheet.Name = "汇总表"
                Selection.Copy
                Sheets("汇总表").Select
                'i = Sheets("汇总表").[a1].CurrentRegion.Rows.Count + 1
                'Sheets("汇总表").Range("A" & i).Select
                Sheets("汇总表").Range("a65536").End(xlUp).Offset(1, 0).Select
                ActiveSheet.Paste
          End If
    Application.CutCopyMode = False
    MsgBox " 复制完成!", Title:="提示"
    'Range("a65536").End(xlUp).Offset(1, 0).Select
   
    End If
    Application.ScreenUpdating = True
End Sub