excel表提取数据

菜鸟呆瓜求带

我需要VBA程序提取数据。主要目的是把清单.xls的sheet2页中数据提取到问卷汇总.xls的sheet2页中，就是把清单.xls的sheet2中相同表头的数据提到问卷汇总.xls的sheet2中相同表头下，具体附件里有。希望大神能帮我下。(┬＿┬)！！(┬＿┬)

LMY123

跨薄，标题行相同，数据自动复制，标题行有合并单元格

菜鸟呆瓜求带

LMY123 发表于 2018-3-21 11:31
跨薄，标题行相同，数据自动复制，标题行有合并单元格

嗯，请问这个怎么实现呢

菜鸟呆瓜求带

自己顶下。。香菇

LMY123

菜鸟呆瓜求带 发表于 2018-3-21 17:03
自己顶下。。香菇

1. Sub Click01()
   
2. Range("a5:z65536") = ""
   
3. Dim arr, arr1, arr2
   
4. Dim Wb As Workbook
   
5. Dim Temp As String
   
6. Dim r&, j%
   
7. arr1 = Sheet2.UsedRange
   
8. Application.ScreenUpdating = False
   
9. Temp = ThisWorkbook.Path & "\清单.xls"
   
10. Set Wb = GetObject(Temp)
    
11. With Wb.Sheets("问卷")
    
12. arr2 = .UsedRange
    
13. ReDim arr(1 To UBound(arr2), 1 To UBound(arr1, 2))
    
14. ReDim brr(1 To UBound(arr2), 1 To UBound(arr1, 2))
    
15. For i = 1 To UBound(arr1, 2)
    
16.     For j = 1 To UBound(arr2, 2)
    
17.         If arr2(3, j) = arr1(3, i) And arr2(3, j) <> "" Then
    
18.             For h = 5 To UBound(arr2)
    
19.                 arr(h - 4, i) = arr2(h, j)
    
20.             Next
    
21.         ElseIf arr2(4, j) = arr1(4, i) And arr2(3, j) = "" Then
    
22.              For h = 5 To UBound(arr2)
    
23.                 brr(h - 4, i) = arr2(h, j)
    
24.             Next
    
25.         End If
    
26.     Next
    
27. Next
    
28. End With
    
29. Wb.Close False
    
30. Set Wb = Nothing
    
31. ReDim crr(1 To UBound(arr2), 1 To UBound(arr1, 2))
    
32. For x = 1 To UBound(crr)
    
33. For y = 1 To UBound(crr, 2)
    
34. If arr(x, y) <> "" Or brr(x, y) <> "" Then
    
35. crr(x, y) = arr(x, y) + brr(x, y)
    
36. End If
    
37. Next y
    
38. Next x
    
39. Sheet2.[a5].Resize(UBound(crr), UBound(crr, 2)) = crr
    
40. Application.ScreenUpdating = True
    
41. End Sub

复制代码