Board logo

標題: [發問] 如何比對Data相異者 ，均copy 彙整到sheets(1)中 [打印本頁]
作者: yangjie    時間: 2015-4-3 11:55     標題: 如何比對Data相異者 ，均copy 彙整到sheets(1)中

請教大大:
sheets(1),sheets(2)之各欄位名均相同,
1.sheets(2)(約100筆)中各列與sheets(1)(約1000筆)相異者 ，均copy 彙整到sheets(1)中
2.判別相異準則:(第一欄至第十二欄要完全一樣)之外都叫相異
若是一欄一欄比對    會落落長
應如何寫才不會落落長?  求救
謝謝
作者: GBKEE    時間: 2015-4-3 14:37

本帖最後由 GBKEE 於 2015-4-7 15:58 編輯

回復 1# yangjie
1:100 多筆資料(第一欄至第十二欄) 導入字典物件
2:比對 1000多筆資料(第一欄至第十二欄)不在字典物件的導入陣列中
  1. Option Explicit
  2. Sub EX()
  3.     Dim d As Object, R As Range, S As String, AR(), i As Integer
  4.     Set d = CreateObject("scripting.dictionary")  '設立字典物件
  5.     ReDim Preserve AR(i)
  6.     AR(i) = Sheets("100多筆").UsedRange.Rows(1).Value
  7.     For Each R In Sheets("100多筆").UsedRange.Rows
  8.         S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
  9.         d(S) = ""
  10.     Next
  11.     For Each R In Sheets("1000多筆").UsedRange.Rows
  12.         S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
  13.         If d.exists(S) = False Then  '字典物件的Key不存在
  14.             i = i + 1
  15.             ReDim Preserve AR(i)
  16.             AR(i) = R.Value
  17.         End If
  18.     Next
  19.     AR = Application.Transpose(Application.Transpose(AR))
  20.     Sheets("Sheet3").[a1].Resize(i + 1, UBound(AR, 2)) = AR
  21. End Sub
複製代碼
作者: yangjie    時間: 2015-4-3 23:45

回復 2# GBKEE
感激GBKEE
1.
因為 欄位有21欄
但判讀相異準則1~12欄 copy是21欄
dictionary 應如何寫
  AR(i) = Sheets("100多筆").UsedRange.Rows(1).Value
  For Each R In Sheets("100多筆").UsedRange.Rows
          S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
          d(S) = ""
  Next
2.
   If d(1).exists(S) = False Then  '字典物件的Key不存在
            i = i + 1
            ReDim Preserve AR(i)
            AR(i) = R.Value
   End If
其中d(1)是甚麼?
3.
Sheets("Sheet3").[a1].Resize(i + 1, UBound(AR, 2)) = AR
  如何修改為最後一列
作者: yangjie    時間: 2015-4-4 01:04

回復 2# GBKEE
但判讀相異準則1~12欄 copy是1~21欄
作者: yangjie    時間: 2015-4-4 02:09

回復  GBKEE
但判讀相異準則1~12欄 copy是1~21欄
yangjie 發表於 2015-4-4 01:04
自自己修正如下
Sub openfile1()
    Dim FileName1 As String
    Dim FileName() As String
    Dim xlfileName As String
    Dim nSelected As Integer
    Dim d As Object, R As Range, S As String, AR(), i As Integer
    Set wb = ActiveWorkbook
    wb.Activate
    path1 = ActiveWorkbook.Path
    ChDir path1
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = path1
        .AllowMultiSelect = True
        .Filters.Add "Excel", "*.xls; *.xlsx", 1
        .Show
        nSelected = .SelectedItems.Count
        ReDim FileName(nSelected)
        For i = 1 To .SelectedItems.Count
            FileName(i - 1) = .SelectedItems(i)
        Next
'用於判讀nothing
        For i = 1 To .SelectedItems.Count
            FileName1 = .SelectedItems(i)
        Next
    End With
    If FileName1 = "" Then
        MsgBox "No file was selected."
        Exit Sub
    End If

    For i = 1 To nSelected
        xlfileName = Dir(FileName(i - 1))
        If xlfileName = wb.Name Then GoTo 50
        If filetoFind(FileName(i - 1)) Then
            Application.EnableEvents = False
            If IsOpen(xlfileName) Then
                Workbooks(xlfileName).Activate
                Set wb1 = Workbooks(xlfileName)
            Else
                Set wb1 = Workbooks.Open(FileName(i - 1))
            End If
            wb.Activate
        Else
            MsgBox "找不著" & FileName(i - 1)
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            'Exit Sub
            GoTo 50
        End If
        Application.EnableEvents = True
        On Error Resume Next
        wb.Activate
        Set d = CreateObject("scripting.dictionary")
        For Each R In Sheets("學生資料").UsedRange.Rows
            'S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
            S = Join(Application.Transpose(Application.Transpose(Range(Sheets("學生資料").Cells(R.Row, 1), Sheets("學生資料").Cells(R.Row, 20)).Value)), ",")  
是否有更好之方式? 若是判讀相異準則為第一第四第九第十欄     那就無轍了            
        d(S) = ""
        Next
        wb1.Activate
        For Each R In Sheets("學生資料").UsedRange.Rows
            'S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
            S = Join(Application.Transpose(Application.Transpose(Range(Sheets("學生資料").Cells(R.Row, 1), Sheets("學生資料").Cells(R.Row, 20)).Value)), ",")
            If d.exists(S) = False Then  '字典物件的Key不存在
                row1 = wb.Sheets("學生資料").Range("A65536").End(xlUp).Row + 1
                wb1.Sheets("學生資料").Rows(R.Row).Copy wb.Sheets("學生資料").Cells(row1, 1)
            End If
        Next
        On Error GoTo 0
        wb.Activate
        wb1.Activate
        wb1.Close False
        Set wb1 = Nothing
50
    Next
    MakeMenu
End Sub
作者: yangjie    時間: 2015-4-6 15:41

回復 2# GBKEE
請教GBKEE版大
我一您方式作更改
wb.Activate
        Set d = CreateObject("scripting.dictionary")
        ReDim Preserve AR(k)
        AR(k) = wb.Sheets("學生資料").UsedRange.Rows(1).Value
        For Each R In Sheets("學生資料").UsedRange.Rows
            S = Join(Application.Transpose(Application.Transpose(Range(Sheets("學生資料").Cells(R.Row, 1), Sheets("學生資料").Cells(R.Row, 20)).Value)), ",")
            d(S) = ""
        Next
        wb1.Activate
        For Each R In Sheets("學生資料").UsedRange.Rows
            S = Join(Application.Transpose(Application.Transpose(Range(Sheets("學生資料").Cells(R.Row, 1), Sheets("學生資料").Cells(R.Row, 20)).Value)), ",")
            If d.exists(S) = False Then  '字典物件的Key不存在
                k = k + 1
                ReDim Preserve AR(k - 1)
                AR(k - 1) = R.Value
            End If
        Next
        row1 = wb.Sheets("學生資料").Range("A65536").End(xlUp).Row + 1
        AR = Application.Transpose(Application.Transpose(AR))
        wb.Sheets("學生資料").Cells(row1, 1).Resize(k, UBound(AR, 2)) = AR
很順   謝謝
想學多點  請教
AR = Application.Transpose(Application.Transpose(AR))    為何要Transpose兩次  ?
UBound(AR, 2)  其中2代表dimension     為何要2  ?
作者: GBKEE    時間: 2015-4-7 17:13

回復 6# yangjie
UBound(AR)  陣列第1維的元素上限索引值,
UBound(AR, 2)  陣列第2維的元素上限索引值
  1. Option Explicit
  2. Sub EX()
  3.     Dim d As Object, R As Range, S As String, AR(), i As Integer, ii As Integer
  4.     Set d = CreateObject("scripting.dictionary")  '設立字典物件
  5.     If Application.CountA(Sheets("Sheet3").Cells) = 0 Then
  6.      '3.Sheets("Sheet3").[a1].Resize(i + 1, UBound(AR, 2)) = AR   如何修改為最後一列
  7.         ReDim Preserve AR(i)
  8.         AR(i) = Sheets("100多筆").UsedRange.Cells(1).Resize(, 12).Value
  9.         i = i + 1
  10.     End If
  11.     '1.因為 欄位有21欄但判讀相異準則1~12欄 copy是21欄,dictionary 應如何寫
  12.     For Each R In Sheets("100多筆").UsedRange.Columns(1).Resize(, 12).Rows
  13.         S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
  14.         '是否有更好之方式? 若是判讀相異準則為第一第四第九第十欄
  15.         'S = R.Cells(1, 1) & R.Cells(1, 4) & R.Cells(1, 9) & R.Cells(1, 10)
  16.         'S = R(1, 1) & R(1, 4) & R(1, 9) & R(1, 10)
  17.         d(S) = ""
  18.     Next
  19.     For Each R In Sheets("1000多筆").UsedRange.Columns(1).Resize(, 12).Rows
  20.         S = Join(Application.Transpose(Application.Transpose(R.Value)), ",")
  21.         'S = R.Cells(1, 1) & R.Cells(1, 4) & R.Cells(1, 9) & R.Cells(1, 10)
  22.         
  23.         If d.exists(S) = False Then  '字典物件的Key不存在
  24.         'If d(1).exists(S) = False Then  '字典物件的Key不存在
  25.         '2 其中d(1)是甚麼?  我的筆誤,原本d要設為陣列,
  26.             ReDim Preserve AR(i)
  27.             AR(i) = R.Value
  28.             i = i + 1
  29.         End If
  30.     Next
  31.     AR = Application.Transpose(Application.Transpose(AR))
  32.     'Sheets("Sheet3").[a1].Resize(i + 1, UBound(AR, 2)) = AR
  33.     '3.Sheets("Sheet3").[a1].Resize(i + 1, UBound(AR, 2)) = AR   如何修改為最後一列
  34.     With Sheets("Sheet3")
  35.        .Cells(.Rows.Count, "a").End(xlUp).Offset(Abs(Application.CountA(.Range("A:A")) > 1)).Resize(i, UBound(AR, 2)) = AR
  36.     End With
  37. End Sub
複製代碼
為何要兩次轉置
如圖
[attach]20596[/attach]

[attach]20597[/attach]
作者: yangjie    時間: 2015-4-10 00:21

回復 7# GBKEE
謝謝老師用心解說  了解很多



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)