求助：如何用VBA比对取多工作表不规则列数据到Sheet1的B列

zouwen

求助：如何用VBA比对取多工作表不规则列数据到Sheet1的B列，见附件

高个子

1. Sub chaxun()
   
2. 
   
3. 
   
4. On Error Resume Next
   
5. 
   
6. For i = 2 To Sheets.Count
   
7.     For j = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
   
8.         Sheet1.Range("d" & j) = Application.WorksheetFunction.VLookup(Sheet1.Range("a" & j), Sheets(i).Range("a:z"), Application.WorksheetFunction.Match("项目", Sheets(i).Range("a1:z1"), 0), 0)
   
9.         
   
10.     Next
    
11. Next
    
12. End Sub

复制代码

feilanga

1. Sub tq()
   
2.     Dim dic As Object
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Dim sht As Worksheet
   
5.     For Each sht In Worksheets
   
6.         If sht.Name <> "汇总" Then
   
7.             arr = sht.UsedRange
   
8.             For j = 1 To UBound(arr, 2)
   
9.                 If arr(1, j) = "项目" Then
   
10.                     j1 = j
    
11.                     Exit For
    
12.                 End If
    
13.             Next
    
14.             For i = 2 To UBound(arr)
    
15.                 If arr(i, 1) <> "" Then
    
16.                     Key = arr(i, 1)
    
17.                     dic(Key) = dic(Key) + arr(i, j1)
    
18.                 End If
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     keys = dic.keys
    
23.     items = dic.items
    
24.     ReDim brr(1 To dic.Count, 1 To 2)
    
25.     For i = 0 To dic.Count - 1
    
26.         k = k + 1
    
27.         brr(k, 1) = keys(i)
    
28.         brr(k, 2) = items(i)
    
29.     Next
    
30.     Sheet1.Range("A2:B" & Rows.Count).ClearContents
    
31.     Sheet1.Range("a2").Resize(dic.Count, 2) = brr
    
32. End Sub

复制代码

lcluck2002

test1216.zip
仅供参考，

gwjkkkkk

Sub TEST()
    Dim arr, brr, i&, wks As Worksheet, R&
    ReDim arr(1 To 10000, 1 To 2)
    For Each wks In Worksheets
        If wks.Name <> "汇总" Then
           With wks
              brr = wks.UsedRange
              For i = 2 To UBound(brr)
                 If brr(i, 1) <> "" Then
                    R = R + 1
                    arr(R, 1) = brr(i, 1): arr(R, 2) = .Cells(i, 1).End(xlToRight)
                 End If
              Next i
           End With
        End If
    Next
    [A2].CurrentRegion.Offset(1).Clear
    [A2].Resize(R, 2) = arr
    Beep
End Sub

gwjkkkkk

参与一下。。。

fzxba

1. Sub test1() '
   
2.   Dim Conn As Object, Sht As Worksheet
   
3.   Dim ar() As String, i As Integer, SQL As String
   
4.   Set Conn = CreateObject("ADODB.Connection")
   
5.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
6.   Worksheets(1).Activate
   
7.   For Each Sht In Worksheets
   
8.     If Sht.Name > ActiveSheet.Name Then
   
9.       i = i + 1
   
10.       ReDim Preserve ar(1 To i)
    
11.       ar(i) = "SELECT 姓名,项目 FROM [" & Sht.Name & "$] WHERE LEN(姓名)"
    
12.     End If
    
13.   Next
    
14.   SQL = ActiveSheet.Name & "$A1:A" & Cells(Rows.Count, "A").End(xlUp).Row
    
15.   SQL = "SELECT a.姓名,b.项目 FROM [" & SQL & "] a LEFT JOIN (" & Join(ar, " UNION ALL ") & ") b ON a.姓名=b.姓名"
    
16.   Range("A2").CopyFromRecordset Conn.Execute(SQL)
    
17.   Conn.Close
    
18.   Set Conn = Nothing
    
19.   Beep
    
20. End Sub

复制代码