返回列表 上一主題 發帖

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

uf023630

帖子
17 
主題
7 
精華
0 
積分
62 
點名
0  
作業系統
WinXP 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
來自
Tinwan 
註冊時間
2011-4-9 
最後登錄
2018-7-6 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-5-14 17:15 | 只看該作者

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

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

diabo

帖子
79 
主題
2 
精華
0 
積分
193 
點名
0  
作業系統
Winwos 7 64 bits 
軟體版本
Excel 2003/2007 
閱讀權限
20 
性別
男 
來自
TAIPEI 
註冊時間
2010-8-25 
最後登錄
2019-9-20 
2#
發表於 2011-5-15 06:57 | 只看該作者
本帖最後由 diabo 於 2011-5-15 07:00 編輯
  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

TOP

diabo

帖子
79 
主題
2 
精華
0 
積分
193 
點名
0  
作業系統
Winwos 7 64 bits 
軟體版本
Excel 2003/2007 
閱讀權限
20 
性別
男 
來自
TAIPEI 
註冊時間
2010-8-25 
最後登錄
2019-9-20 
3#
發表於 2011-5-15 07:00 | 只看該作者
記得在 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

TOP

diabo

帖子
79 
主題
2 
精華
0 
積分
193 
點名
0  
作業系統
Winwos 7 64 bits 
軟體版本
Excel 2003/2007 
閱讀權限
20 
性別
男 
來自
TAIPEI 
註冊時間
2010-8-25 
最後登錄
2019-9-20 
4#
發表於 2011-5-15 07:01 | 只看該作者
看不懂問題3
diabo

TOP

oobird
　頭銜: 街友一族

超級版主Rank: 8Rank: 8

帖子
1572 
主題
16 
精華
2 
積分
1521 
點名
0  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
150 
性別
男 
註冊時間
2010-5-1 
最後登錄
2016-1-13 

論壇貢獻勳章
5#
發表於 2011-5-15 16:53 | 只看該作者
問題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
複製代碼

TOP

        靜思自在 : 謊言像一朵盛開的鮮花，外表美麗，生命短暫。
返回列表 上一主題