[發問] 大量資料篩選不重複並分類

uf023630

我遇到大量資料須要分開處理,想請大家幫忙
問題.rar (14.17 KB)

下載次數: 38

2011-5-14 17:06

diabo

1.    '問題1
   
2.     end_row = Sheets("ASD1").[A65536].End(xlUp).Row
   
3.     For Each aaa In Array("DL", "BA", "STOCK")
   
4.         With Sheets("ASD1")
   
5.             .Range("A1:C" & end_row).AutoFilter Field:=2, Criteria1:="=" & aaa
   
6.             .Range("A1:C" & end_row).SpecialCells(xlCellTypeVisible).Copy
   
7.              Sheets(aaa).Range("A1").PasteSpecial Paste:=xlPasteValues
   
8.         End With
   
9.     Next

複製代碼

diabo

記得在 VBE中設定引用項目勾選 Microsoft ActiveX Data Objects 2.x Library

1.    '問題2
   
2.     Dim strConn As String, strSQL As String
   
3.     Dim conn As ADODB.Connection
   
4.     Dim rs As ADODB.Recordset
   
5.    
   
6.     strConn = "Driver={Microsoft Excel Driver (*.xls)};" & _
   
7.               "DBQ=" + ThisWorkbook.FullName + ";" & _
   
8.               "ReadOnly=True"
   
9.       
   
10.     Set conn = CreateObject("ADODB.Connection")
    
11.     Set rs = CreateObject("ADODB.Recordset")
    
12.    
    
13.     strSQL = "SELECT ITNO, SUM(TQT) AS TQT2 From ((SELECT ITNO,TQT FROM [ASD1$] WHERE LEN(WHS)=6 ORDER BY ITNO) tmpTable) GROUP BY ITNO"
    
14.    
    
15.     conn.Open strConn
    
16.     rs.Open strSQL, conn, 3, 1
    
17.    
    
18.     With Sheets("BFTTL")
    
19.         .Range("A2:B" & .[A65536].End(xlUp).Row).Cells.ClearContents
    
20.         .Cells(2, 1).CopyFromRecordset rs
    
21.     End With
    
22.         
    
23.     rs.Close
    
24.     Set rs = Nothing
    
25.    
    
26.     conn.Close
    
27.     Set conn = Nothing

複製代碼

diabo

看不懂問題3

oobird

問題3

1. Sub yy()
   
2.     Dim d As Object, a, b, i&, j%, k%, m%, n%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     k = 1
   
5.     With Sheets("ASD1")
   
6.         a = .Range(.[a2], .[c65536].End(3))
   
7.         ReDim b(1 To UBound(a), 1 To 3)
   
8.         For i = 1 To UBound(a)
   
9.             If Len(a(i, 2)) = 6 Then
   
10.                 m = m + 1
    
11.                 For j = 1 To 3
    
12.                     b(m, j) = a(i, j)
    
13.                 Next
    
14.             End If
    
15.         Next
    
16.         Do
    
17.             For i = 1 To m
    
18.                 If b(i, 2) <> "" Then
    
19.                     If Not d.exists(b(i, 1)) Then
    
20.                         d(b(i, 1)) = Array(b(i, 1) & "", b(i, 2), b(i, 3))
    
21.                         b(i, 2) = "": n = n + 1
    
22.                     End If
    
23.                 End If
    
24.             Next
    
25.             If d.Count > 0 Then
    
26.                 Sheets("BF12").Cells(1, k).Resize(, 3) = .[a1:c1].Value
    
27.                 Sheets("BF12").Cells(2, k).Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
    
28.                 d.RemoveAll
    
29.                 k = k + 3
    
30.             End If
    
31.         Loop Until n = m
    
32.     End With
    
33. End Sub

複製代碼