[已解决]这样的筛选复制要怎样改啊？请朋友帮忙看看吧！！

jymydms

这是我记的一个流水账，想在里面设计一个按键（里面有一个按键是符合条件变色用的），如果表1的L1单元格输入的是“邓发财”，那么复制表1中含有邓发财的项到表3（像我表2手动筛选复制的一样），请高手朋友给看看吧，谢谢啦 求助流水账记录.rar (19.69 KB, 下载次数: 7)

2014-10-28 13:09 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-10-28 15:25

1. Sub test3()
   
2.     Dim str$, arr, result()
   
3.     Dim i&, j&, k&, lStart&, lEnd&, lTemp&, l&
   
4.     str = Sheet6.Range("l1").Value
   
5.     If Len(str) = 0 Then
   
6.         MsgBox "查找内容为空"
   
7.         Exit Sub
   
8.     End If
   
9.     arr = Sheet6.Range("a1").CurrentRegion.Value
   
10.     If Not IsArray(arr) Then
    
11.         MsgBox "无数据可操作"
    
12.         Exit Sub
    
13.     End If
    
14.     ReDim result(1 To UBound(arr), 1 To 7)
    
15.     For i = LBound(arr) + 1 To UBound(arr)
    
16.         If InStr(1, arr(i, 4), str) Then
    
17.             lStart = i
    
18.             lEnd = i
    
19.             Do While Len(arr(lStart, 1)) = 0
    
20.                 lStart = lStart - 1
    
21.             Loop
    
22.             If lEnd < UBound(arr) Then
    
23.                 Do While Len(arr(lEnd + 1, 1)) = 0
    
24.                     lEnd = lEnd + 1
    
25.                     If lEnd = UBound(arr) Then
    
26.                         Exit Do
    
27.                     End If
    
28.                 Loop
    
29.             Else
    
30.                 lEnd = i
    
31.             End If
    
32. 
    
33.             Debug.Print i, lStart, lEnd
    
34.             For lTemp = lStart To lEnd
    
35.                 k = k + 1
    
36.                 For l = 1 To 4
    
37.                     result(k, l) = arr(lTemp, l)
    
38.                 Next
    
39.                 For l = 10 To 12
    
40.                     result(k, l - 5) = arr(lTemp, l)
    
41.                 Next
    
42.             Next
    
43.             i = lEnd
    
44.         End If
    
45.     Next
    
46.     Application.ScreenUpdating = False
    
47.     Sheet1.Cells(Rows.Count, 4).End(xlUp).Offset(1, -3).Resize(k, UBound(result, 2)).Value = result
    
48.     Sheet1.Columns("a:g").AutoFit
    
49.     MsgBox "筛选完成"
    
50. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

表格设计不太好，不需要使用到合并单元格，另外，同一个单元格里其实也是可以换行来实现的。

hwc2ycy

1. Sub test2()
   
2.     Dim str$, arr, result()
   
3.     Dim i&, j&, k&, lStart&, lEnd&, lTemp&, l&
   
4.     str = Sheet6.Range("l1").Value
   
5.     If Len(str) = 0 Then
   
6.         MsgBox "查找内容为空"
   
7.         Exit Sub
   
8.     End If
   
9.     arr = Sheet6.Range("a1").CurrentRegion.Value
   
10.     If Not IsArray(arr) Then
    
11.         MsgBox "无数据可操作"
    
12.         Exit Sub
    
13.     End If
    
14.     ReDim result(1 To UBound(arr), 1 To 7)
    
15.     For i = LBound(arr) + 1 To UBound(arr)
    
16.         If InStr(1, arr(i, 4), str) Then
    
17.             lStart = i
    
18.             lEnd = i
    
19.             '起始行
    
20.             If Len(arr(i, 1)) Then
    
21.                 lStart = i
    
22.             Else
    
23.                 Do
    
24.                     lStart = lStart - 1
    
25.                 Loop Until Len(arr(lStart, 1))
    
26.             End If
    
27. 
    
28.             If i < UBound(arr) Then
    
29.                 If Len(arr(i + 1, 1)) = 0 Then
    
30.                     Do While Len(arr(lEnd, 1)) > 0
    
31.                         lEnd = lEnd + 1
    
32.                     Loop
    
33.                 End If
    
34.                 Debug.Print i, lStart, lEnd
    
35.             Else
    
36.                 If i = UBound(arr) Then
    
37.                     lStart = i
    
38.                     If Len(arr(i, 1)) = 0 Then
    
39.                         Do
    
40.                             lStart = lStart - 1
    
41.                         Loop Until Len(arr(lStart, 1))
    
42.                     Else
    
43.                         lStart = i
    
44.                     End If
    
45.                 End If
    
46.                 Debug.Print i, lStart, lEnd
    
47.             End If
    
48.             For lTemp = lStart To lEnd
    
49.                 k = k + 1
    
50.                 For l = 1 To 4
    
51.                     result(k, l) = arr(lTemp, l)
    
52.                 Next
    
53.                 For l = 10 To 12
    
54.                     result(k, l - 5) = arr(lTemp, l)
    
55.                 Next
    
56.             Next
    
57.             i = lEnd
    
58.         End If
    
59.     Next
    
60.     Application.ScreenUpdating = False
    
61.     Sheet1.Cells(Rows.Count, 1).End(xlUp).Resize(k, UBound(result, 2)).Value = result
    
62.     Sheet1.Columns("a:g").AutoFit
    
63.     MsgBox "筛选完成"
    
64. End Sub

复制代码

hwc2ycy

1. Sub test3()
   
2.     Dim str$, arr, result()
   
3.     Dim i&, j&, k&, lStart&, lEnd&, lTemp&, l&
   
4.     str = Sheet6.Range("l1").Value
   
5.     If Len(str) = 0 Then
   
6.         MsgBox "查找内容为空"
   
7.         Exit Sub
   
8.     End If
   
9.     arr = Sheet6.Range("a1").CurrentRegion.Value
   
10.     If Not IsArray(arr) Then
    
11.         MsgBox "无数据可操作"
    
12.         Exit Sub
    
13.     End If
    
14.     ReDim result(1 To UBound(arr), 1 To 7)
    
15.     For i = LBound(arr) + 1 To UBound(arr)
    
16.         If InStr(1, arr(i, 4), str) Then
    
17.             lStart = i
    
18.             lEnd = i
    
19.             Do While Len(arr(lStart, 1)) = 0
    
20.                 lStart = lStart - 1
    
21.             Loop
    
22.             If lEnd < UBound(arr) Then
    
23.                 Do While Len(arr(lEnd + 1, 1)) = 0
    
24.                     lEnd = lEnd + 1
    
25.                     If lEnd = UBound(arr) Then
    
26.                         Exit Do
    
27.                     End If
    
28.                 Loop
    
29.             Else
    
30.                 lEnd = i
    
31.             End If
    
32. 
    
33.             Debug.Print i, lStart, lEnd
    
34.             For lTemp = lStart To lEnd
    
35.                 k = k + 1
    
36.                 For l = 1 To 4
    
37.                     result(k, l) = arr(lTemp, l)
    
38.                 Next
    
39.                 For l = 10 To 12
    
40.                     result(k, l - 5) = arr(lTemp, l)
    
41.                 Next
    
42.             Next
    
43.             i = lEnd
    
44.         End If
    
45.     Next
    
46.     Application.ScreenUpdating = False
    
47.     Sheet1.Cells(Rows.Count, 4).End(xlUp).Offset(1, -3).Resize(k, UBound(result, 2)).Value = result
    
48.     Sheet1.Columns("a:g").AutoFit
    
49.     MsgBox "筛选完成"
    
50. End Sub

复制代码

hwc2ycy

求助流水账记录.rar (27.28 KB, 下载次数: 7)

2014-10-28 15:34 上传

点击文件名下载附件

jymydms

hwc2ycy 发表于 2014-10-28 15:34

谢谢版主！这么快就给问题解决了！！！