想在在同一个工作簿中，把各个表中的指定内容提取出来

gyll

想在在同一个工作簿中，把各个表中的指定内容提取出来。公式、函数、VBa都可以

gyll

朱荣兴 发表于 2018-2-14 01:20
只能是vba,明天看看

谢谢，感谢版主

鄂龙蒙

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Address <> "$C$4" Then Exit Sub
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     For Each sh In Worksheets
   
5.         If sh.Name <> ActiveSheet.Name Then
   
6.             ar = sh.UsedRange
   
7.             For i = 3 To UBound(ar)
   
8.                 d(ar(i, 3)) = ""
   
9.             Next
   
10.       End If
    
11.     Next
    
12.     k = Join(d.keys, ",")
    
13.     With [C4].Validation
    
14.         .Delete: .Add xlValidateList, , , k
    
15.     End With
    
16.     Set d = Nothing
    
17. End Sub
    
18. 
    
19. Private Sub Worksheet_Change(ByVal Target As Range)
    
20.     If Target.Address <> "$C$4" Then Exit Sub
    
21.     Dim sh As Worksheet
    
22.     Dim r, i, s
    
23.     Range("A7:AK100").ClearContents
    
24.     Application.ScreenUpdating = False
    
25.         s = 7
    
26.         For Each sh In Worksheets
    
27.             If sh.Name <> ActiveSheet.Name Then
    
28.                 r = sh.[C1048576].End(3).Row
    
29.                 For i = 3 To r
    
30.                     If sh.Cells(i, 3) = Cells(4, 3) Then
    
31.                         Cells(s, 1) = sh.Name
    
32.                         For j = 1 To 37
    
33.                             Cells(s, j + 1) = sh.Cells(i, j)
    
34.                         Next
    
35.                         s = s + 1
    
36.                     End If
    
37.                 Next
    
38.             End If
    
39.         Next
    
40.     Application.ScreenUpdating = True
    
41. End Sub
    

复制代码

abc123281

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Dim arr, brr(1 To 1000, 1 To 27), crr(1 To 1, 1 To 27)
   
3. Dim ws As Worksheet
   
4. With Worksheets("查询")
   
5.   .[a7:ak100].ClearContents
   
6. End With
   
7. For Each ws In Worksheets
   
8.   If ws.Name <> "查询" Then
   
9.      With ws
   
10.        n = 0
    
11.         rw = .[c65536].End(3).Row
    
12.         arr = .Range("c3:ak" & rw)
    
13.            For i = 1 To UBound(arr)
    
14.              n = n + 1
    
15.              brr(n, 1) = ws.Name
    
16.              brr(n, 2) = arr(i, 1)
    
17.                For j = 11 To UBound(arr, 2)
    
18.                  brr(n, j - 8) = arr(i, j)
    
19.                Next
    
20.           Next
    
21.      End With
    
22.       With Worksheets("查询")
    
23.           For x = 1 To UBound(brr)
    
24.              If Cells(4, "i") = brr(x, 2) Then
    
25.                 For y = 1 To 27
    
26.                   crr(1, y) = brr(x, y)
    
27.                 Next
    
28.              End If
    
29.           Next
    
30.       End With
    
31.   End If
    
32.   Worksheets("查询").[j65536].End(3).Offset(1, 0).Resize(1, 27) = crr
    
33.   Erase crr
    
34. Next
    
35. End Sub

复制代码

abc123281

查询 abc123.rar (180.71 KB, 下载次数: 11)

2018-2-14 16:10 上传

点击文件名下载附件

gyll

abc123281 发表于 2018-2-14 16:10

感谢，学习中。有些地方没看懂，能帮我注释一下么？还有，我想提取出我需要的部分列，不想一行都提取，该怎么变动？

abc123281

呵呵  论坛上老师们帮助别人写代码一般都不写注释的

abc123281

想当初 我们学习时也是这样的   如果是为了学习  主要靠自己去解读代码  这需要一定的vba基础

abc123281

如果有不懂的地方倒是可以提问