[發問] 如何比對Data相異者 ，均copy 彙整到sheets(1)中

帖子: 258
主題: 77
精華: 0
積分: 385
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-8-8
最後登錄: 2021-1-25

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2015-4-3 11:55 | 顯示全部帖子

[發問] 如何比對Data相異者，均copy 彙整到sheets(1)中

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

樓主熱帖

帖子: 258
主題: 77
精華: 0
積分: 385
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-8-8
最後登錄: 2021-1-25

2^#

發表於 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
  如何修改為最後一列

帖子: 258
主題: 77
精華: 0
積分: 385
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-8-8
最後登錄: 2021-1-25

3^#

發表於 2015-4-4 01:04 | 顯示全部帖子

回復 2# GBKEE
但判讀相異準則1~12欄 copy是1~21欄

帖子: 258
主題: 77
精華: 0
積分: 385
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-8-8
最後登錄: 2021-1-25

4^#

發表於 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

帖子: 258
主題: 77
精華: 0
積分: 385
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-8-8
最後登錄: 2021-1-25

5^#

發表於 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  ?