麻辣家族討論版版 - Powered by Discuz! Board

標題: 匯出_但不重覆匯出的資料 [打印本頁]

作者: hugh0620 時間: 2011-1-4 11:24 標題: 匯出_但不重覆匯出的資料

Dear 大大

   小弟又來發問問題了~ 但先祝各位大大新年快樂~ 以後多照顧 ^^
   小弟的問題在於將輸入好的資料匯出後,但要先比對Data中是否有重覆,以避免重覆計算

   1.使用者會在sheet[輸入]中,將資料輸入,再點選{匯出}
   2. 匯出時為避免重覆計算,其條件[日期]and[CPO]and[組別]三者不可以重覆

   如附件為問題濃縮的範例  [attach]4302[/attach]

作者: Hsieh 時間: 2011-1-4 12:01

回復 1# hugh0620

Private Sub CommandButton1_Click()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
ar = .Range(.[B5], .[B5].End(xlDown).Offset(, 2))
For i = 1 To UBound(ar, 1)
mystr = Join(Application.Index(ar, i))
d(mystr) = d.Count
Next
With Sheet1
ar = .Range(.[B5], .[B5].End(xlDown).Offset(, 3))
For i = 1 To UBound(ar, 1)
mystr = Join(Array(ar(i, 1), ar(i, 2), ar(i, 3)))
If d.exists(mystr) = False Then
ReDim Preserve Ay(s)
Ay(s) = Application.Index(ar, i)
s = s + 1
End If
Next
End With
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
End With
End Sub

複製代碼

作者: hugh0620 時間: 2011-1-4 14:11

回復 2# Hsieh

Dear 超版主大大

  真的很感謝你,很快的就解決我的問題,我也有將您的每行程式碼細細測試並了解
  大大用的方式是先將資料記錄起來,再用陣列的方式比對,看是否有不一樣的資料
  再將不一樣的資料記錄起來,最後再將不一樣的資料放在DATA中

  因為我給大大的範例是屬於條件式都是在一起的情況下,但是大大若我的條件修改為不是連續的情況下 (亦極條件與條件中間是有其他資料的時候)
  我有試著自行修改,但無奈小弟功力尚淺,無法用大大的模式修改好
  只好再請大大指教

  附件為問題之範例[attach]4303[/attach]

作者: Hsieh 時間: 2011-1-4 15:38

本帖最後由 Hsieh 於 2011-1-4 15:49 編輯

回復 3# hugh0620

Private Sub CommandButton1_Click()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
ar = .Range(.[B5], .[B5].End(xlDown).Offset(, 2))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Application.Index(ar, i))
d(mystr1) = d.Count
Next
With Sheet1
ar = .Range(.[B5], .[B5].End(xlDown).Offset(, 6))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
If d.exists(mystr1) = False Then
ReDim Preserve Ay(s)
Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
s = s + 1
End If
Next
End With
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
End With
End Sub

複製代碼

作者: hugh0620 時間: 2011-1-4 17:59

回復 4# Hsieh

Dear 大大
      感謝~ 我知道要改哪邊了~ 程式碼執行上也沒有問題~
         但是小弟在測試時~ 又胡思亂想~ 結果~ 找出了一個問題~
         就是若Data中~一開始就沒有資料或是僅一筆資料的時候好像是就會產生問題~
         For i = 1 To UBound(ar, 1) 該行指令中UBound(ar, 1) 就會等於65536 造成一直跑不停

      再請大大賜教一下

      附件為問題之範本[attach]4304[/attach]

作者: hugh0620 時間: 2011-1-4 18:19

回復 4# Hsieh

Dear 大大
   我用一個很笨的方式來處理當DATA無資料時,所產生的問題
   不知道大大是否有其他方式
   這是我用大大的程式碼修改 (紅色為我新增的地方)
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
ar = .Range(.[B5], .[B5].End(xlDown).Offset(, 2))
      If UBound(ar, 1) = 0 Or UBound(ar, 1) = 65536 - 4 Then
         For i = 1 To 1
            mystr1 = Join(Application.Index(ar, i))
            d(mystr1) = d.Count
         Next
      Else          For i = 1 To UBound(ar, 1)
            mystr1 = Join(Application.Index(ar, i))
            d(mystr1) = d.Count
         Next
      End If With Sheet1
      ar = .Range(.[B5], .[B5].End(xlDown).Offset(, 6))
      For i = 1 To UBound(ar, 1)
         mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
         If d.exists(mystr1) = False Then
            ReDim Preserve Ay(s)
            Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
            s = s + 1
         End If
      Next
End With
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
End With

作者: Hsieh 時間: 2011-1-4 20:03

回復 7# hugh0620

Private Sub CommandButton1_Click()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 2))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Application.Index(ar, i))
d(mystr1) = d.Count
Next
With Sheet1
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 6))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
If d.exists(mystr1) = False Then
ReDim Preserve Ay(s)
Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
s = s + 1
End If
Next
End With
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
End With
End Sub

複製代碼

作者: hugh0620 時間: 2011-1-5 09:36

回復 7# Hsieh

謝謝大大~ 原來只要把xldown 改成xlup就可以將bug給克服

作者: hugh0620 時間: 2011-1-6 18:14

回復 7# Hsieh

Dear 大大

      小弟又小卡彈了~ 大大我需要將資料匯出,但是Data的部份又要保護避免被使用者修改(使用者僅能看)
         如果我把工作頁保護了,匯出的時候程式執行就會產生錯誤
      這樣的問題是否可以解決呢??

         附件為問題之範本[attach]4334[/attach]

作者: Hsieh 時間: 2011-1-6 18:30

本帖最後由 Hsieh 於 2011-1-6 19:06 編輯

回復 9# hugh0620

Private Sub CommandButton1_Click()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
.Unprotect "password" 'password指工作表保護密碼
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 2))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Application.Index(ar, i))
d(mystr1) = d.Count
Next
With Sheet1
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 6))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
If d.exists(mystr1) = False Then
ReDim Preserve Ay(s)
Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
s = s + 1
End If
Next
End With
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
.Protect "password" 'password指工作表保護密碼
End With
End Sub

複製代碼

作者: hugh0620 時間: 2011-1-7 10:40

回復 10# Hsieh

謝謝大大~ 問題解決了
只要在匯前解開(Unprotect)與匯後鎖上就好了(Protect)

真是感謝大大~ 我的整份報表慢慢將完成

作者: hugh0620 時間: 2011-1-10 11:28

回復 10# Hsieh

Dear 大大

小小卡彈中,若是sheet[Data]中已有一筆資,我經過測試後,在活頁[輸入]就匯不過去了,
執行的時候發現是 mystr1 = Join(Application.Index(ar, i)) 這行指令會產生{執行階段錯誤"13" 型態不符}
請大大指導一下~

問題如附件之範本[attach]4361[/attach]

作者: Hsieh 時間: 2011-1-10 11:40

回復 12# hugh0620
那就乖一點

Private Sub CommandButton1_Click()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
.Unprotect "1234"
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 2))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 3)))
d(mystr1) = d.Count
Next
With Sheet1
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 6))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
If d.exists(mystr1) = False Then
ReDim Preserve Ay(s)
Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
s = s + 1
End If
Next
End With
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
.Protect "1234"
End With
End Sub

複製代碼

作者: hugh0620 時間: 2011-1-10 11:54

回復 13# Hsieh

Dear 大大~ 感恩~ 原來只要把那行程式碼改成array的方式就可以解決
真的很感謝你~

作者: hugh0620 時間: 2011-1-12 11:16

回復 13# Hsieh

   Dear 大大

      若是重覆的資料,有資料是KEY IN錯誤,但是已經按了匯出資料,
         需要將依匯出的條件UPDATE錯務的地方,請大大指教一下

      附件為問題之範本[attach]4379[/attach]

作者: Hsieh 時間: 2011-1-12 16:14

回復 15# hugh0620

Private Sub CommandButton1_Click()
Dim Ay()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheet2
.Unprotect "1234"
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 2))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 3)))
d(mystr1) = d.Count
Next
With Sheet1
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 6))
For i = 1 To UBound(ar, 1)
mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
If d.exists(mystr1) = False Then
ReDim Preserve Ay(s)
Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
s = s + 1
Else
d1(mystr1) = ar(i, 7)
End If
Next
End With
For Each a In .Range(.[B5], .[B65536].End(xlUp))
mystr1 = Join(Array(a, a.Offset(, 1), a.Offset(, 2)))
a.Offset(, 3) = d1(mystr1)
Next
If s > 0 Then .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = Application.Transpose(Application.Transpose(Ay))
.Protect "1234"
End With
End Sub

複製代碼

作者: hugh0620 時間: 2011-1-19 16:49

回復 16# Hsieh

大大~ 因為輸日介面會每日一直輸入~ 若是這樣
測試後的結果會有一個問題~ 就是如果第1次(依日期:第1天)輸入~ 按匯出後~ DATA會帶出數量~
但是~ 第2次(依日期:第2天)輸入~ 按匯出後~ DATA會帶出第2次輸入的數量~ 但是第一次輸入的數量會不見~>.<

作者: Hsieh 時間: 2011-1-19 17:10

回復 17# hugh0620

你不是希望覆寫嗎?
當然比對到重複的就被新的取代阿

作者: hugh0620 時間: 2011-1-19 17:28

回復 18# Hsieh

大大明鑑
覆寫的部份針對的是[同一天]且[同一個CPO]且[同一組]的條件下進行覆寫DATA同樣的資料
若是[不同天]或[不同CPO]或[不同組]就需要新增資料到DATA

作者: Andy2483 時間: 2023-3-15 20:13

本帖最後由 Andy2483 於 2023-3-15 20:20 編輯

回復 11# hugh0620
回復 16# Hsieh

謝謝論壇,謝謝前輩
後學藉此帖學習到很多知識,以下心得註解,請前輩再指導

Option Explicit
Sub TEST()
Dim Ay(), d, d1, ar, i, a, s, mystr1
'↑宣告變數:Ay是陣列,其餘為通用型變數
Set d = CreateObject("Scripting.Dictionary")
'↑令d是字典
Set d1 = CreateObject("Scripting.Dictionary")
'↑令d1也是字典
With Sheet2
'↑以下是關於Sheet2工作表的程序 (Data表)
.Unprotect "1234"
'↑令以"1234"密碼取消保護工作表
ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 2))
'↑令ar變數是二維陣列,以[B5]到(B欄最後一個有內容儲存格,
'再向右偏移2欄的儲存格),此範圍儲存格值帶入ar陣列中
For i = 1 To UBound(ar, 1)
'↑設順迴圈!i從1到 ar縱向最大索引列號
   mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 3)))
   '↑令mystr1變數是以空白字元連結陣列子值的新字串
   '陣列子值:i迴圈數的(1,2,3)欄ar陣列值
   d(mystr1) = d.Count
   '↑令以mystr1變數當key,item是 d字典key數量(PS:起始值是0),納入d字典
Next
With Sheet1
'↑以下是關於Sheet1工作表的程序 (輸入表)
   ar = .Range(.[B5], .[B65536].End(xlUp).Offset(, 6))
   '↑令ar變數裝新資料:
   '令ar是二維陣列,以[B5]到(B欄最後一個有內容儲存格,
   '再向右偏移6欄的儲存格),此範圍儲存格值帶入ar陣列中
   For i = 1 To UBound(ar, 1)
   '↑設順迴圈!i從1到 ar縱向最大索引列號
      mystr1 = Join(Array(ar(i, 1), ar(i, 2), ar(i, 6)))
      '↑令mystr1變數是以空白字元連結陣列子值的新字串
      '陣列子值:i迴圈數的(1,2,6)欄ar陣列值
      If d.exists(mystr1) = False Then
      '↑如果查d字典裡沒有 mystr1變數 key
         ReDim Preserve Ay(s)
         '↑令Ay陣列擴充列數到索引號s(PS:s起始值是0)
         Ay(s) = Array(ar(i, 1), ar(i, 2), ar(i, 6), ar(i, 7))
         '↑令s變索引號Ay陣列值是一維陣列,以i迴圈列ar陣列子值(1,2,6,7)帶入
         s = s + 1
         '↑令s變數累加 1
         Else
            d1(mystr1) = ar(i, 7)
            '↑否則令以mystr1變數為key,item是i迴圈列第7欄ar陣列值,納入d1字典中
      End If
   Next
End With
For Each a In .Range(.[B5], .[B65536].End(xlUp))
'↑設逐項迴圈!令a是 (Data表[B5]到 B欄最後一個有內容儲存格)這範圍儲存格之一
   mystr1 = Join(Array(a, a.Offset(, 1), a.Offset(, 2)))
   '↑令mystr1變數是以空白字元連結陣列子值的新字串
   '陣列子值:a變數值,a變數往右偏移1格的儲存格值,a變數往右偏移2格的儲存格值
   a.Offset(, 3) = d1(mystr1)
   '↑令a變數往右偏移3格的儲存格值是以mystr1變數查d1字典的item值
Next
If s > 0 Then
'↑如果s變數大於 0?
   .[B65536].End(xlUp).Offset(1, 0).Resize(s, 4) = _
   Application.Transpose(Application.Transpose(Ay))
   '↑令Data表B欄第1空白格擴展向下s1變數列,向右擴展4欄,
   '這擴展範圍儲存格值以Ay陣列轉置兩次的值帶入
End If
.Protect "1234"
'↑令以"1234"密碼保護Data表
End With
End Sub

作者: Andy2483 時間: 2023-3-16 10:33

謝謝論壇,謝謝各位前輩
後學今天藉此帖練習陣列與字典,請各位前輩指教
[attach]35958[/attach]

資料表:
[attach]35959[/attach]

原結果表:
[attach]35960[/attach]

執行結果:
[attach]35961[/attach]

Option Explicit
Sub TEST_1()
Dim A, B, V, Y, Z, C%, R&, i&, N&, T$, xR
Set Y = CreateObject("Scripting.Dictionary")
[Data!F:F].ClearContents
Set xR = Range([Data!F5], [Data!B65536].End(3))
A = xR: B = Range([輸入!H5], [輸入!B65536].End(3))
ReDim V(UBound(B), 4): Z = Array(1, 2, 6, 7)
For i = 1 To UBound(A)
T = Join(Array(A(i, 1), A(i, 2), A(i, 3)), "|")
Y(T) = i: Y(T & "/c4") = A(i, 4)
Next
For i = 1 To UBound(B)
T = Join(Array(B(i, 1), B(i, 2), B(i, 6)), "|")
If Y.Exists(T) Then
   N = Y(T)
   If B(i, 7) <> Y(T & "/c4") And N <= UBound(A) Then
      A(N, 5) = Date & "_" & A(N, 4) & "_修改為_" & B(i, 7)
      A(N, 4) = B(i, 7)
   End If
   Else
      For C = 0 To 3: V(R, C) = B(i, Z(C)): Next
      V(R, 4) = "新增"
      R = R + 1: Y(T) = i: Y(T & "/c4") = B(i, 7)
End If
Next
xR.Value = A
If R > 0 Then xR.Item(xR.Count + 1).Resize(R, 5) = V
Application.Goto [Data!A1]
Set Y = Nothing: Erase A, B, V
End Sub

作者: Andy2483 時間: 2023-3-17 09:16

本帖最後由 Andy2483 於 2023-3-17 09:26 編輯

回復 21# Andy2483

謝謝論壇,謝謝各位前輩
今天複習此帖發現很多缺漏,修正後心得註解如下,請各前輩指教

Option Explicit
Sub TEST_1()
If [輸入!B65536].End(3).Row <= 5 Then Exit Sub
'↑如果輸入表B欄最後一個有內容儲存格列號<=5!就結束程式執行
Dim A, B, V, Y, Z, C%, R&, i&, N&, T$, xR As Range
'↑宣告變數:(A,B,V,Y,Z)是通用型變數,C是短整數變數,
'(R,i,N)是長整數變數,T是字串變數,xR是儲存格變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是字典
[Data!F:F].ClearContents
'↑令Data表F欄清除內容
Set xR = Range([Data!F4], [Data!B65536].End(3))
'↑令xR這儲存格變數是 Data表[F4]到B欄最後一個有內容儲存格
A = xR: B = Range([輸入!H5], [輸入!B65536].End(3))
'↑令A這通用型變數是二維陣列,以xR變數值(儲存格值)帶入,
'令B這通用型變數是二維陣列,以輸入表[H5]到B欄最後有內容儲存格,
'這範圍儲存格值帶入B陣列中
ReDim V(UBound(B), 4): Z = Array(1, 2, 6, 7)
'↑宣告V這通用型變數是二維陣列,縱向範圍從0到 B陣列縱向最大列號,
'橫向範圍從0到 4
'令Z這通用型變數是一維陣列,以數字(1,2,6,7)為其陣列值
For i = 2 To UBound(A)
'↑設順迴圈!i從2到 A陣列縱向最大索引列號
T = Join(Array(A(i, 1), A(i, 2), A(i, 3)), "|")
'↑令T這字串變數是以"|"連結A陣列值的新字串,
'A陣列值:i迴圈列(1,2,3)欄A陣列值
Y(T) = i: Y(T & "/c4") = A(i, 4)
'↑令以T變數為key,item是 i迴圈數,納入Y字典裡
'令以T變數連結"/c4"後的新字串為key,item是 i迴圈列第4欄A陣列值,
'納入Y字典裡
Next
For i = 1 To UBound(B)
'↑設順迴圈!i從2到 B陣列縱向最大索引列號
T = Join(Array(B(i, 1), B(i, 2), B(i, 6)), "|")
'↑令T這字串變數是以"|"連結B陣列值的新字串,
'B陣列值:i迴圈列(1,2,6)欄B陣列值
If Y.Exists(T) Then
'↑如果Y字典裡有 T變數這key?
   N = Y(T)
   '↑令N這長整數變數是以T變數查Y字典回傳的item值
   If B(i, 7) <> Y(T & "/c4") And N <= UBound(A) Then
   '↑如果i迴圈列第7欄陣列值不等於以T變數連結"/c4"的Y item值
   '而且N變數<= A陣列縱向最大索引列號(目的:隔離新增)
      A(N, 5) = Date & "_" & A(N, 4) & "_修改為_" & B(i, 7)
      '↑令N變數列第5欄A陣列值是今天日期連接"_",
      '再連接N變數列第4欄A陣列值,續連接"_修改為_",
      '最後連接i迴圈列第7欄B陣列值
      A(N, 4) = B(i, 7)
      '↑令N變數列第4欄A陣列值是 i迴圈列第7欄B陣列值
   End If
   Else
      For C = 0 To 3: V(R, C) = B(i, Z(C)): Next
      '↑設順迴圈C從0到 3
      '令R這長整數變數列第C變數欄V陣列值是
      'i迴圈列第(C變數索引號Z陣列值)欄的B陣列值
      'R變數的初始值是0,V縱向索引號起始值也是0,要搭配才對得準
      V(R, 4) = "新增"
      '↑令R變數列第4欄V陣列值是 "新增"字串
      R = R + 1: Y(T) = i: Y(T & "/c4") = B(i, 7)
      '↑令R變數累加1:令以T變數當key,item是 i迴圈數,納入Y字典裡,
      '令以T變數連結"/c4"後的新字串為key,item是 i迴圈列第7欄B陣列值,
      '納入Y字典裡
End If
Next
xR = A
'↑令xR變數(儲存格)值以A陣列值帶入
If R > 0 Then xR.Item(xR.Count + 1).Resize(R, 5) = V
'↑如果R變數>0 !
'就令xR變數(儲存格)的下一個儲存格擴展向下R變數列,向右擴展5欄,
'這範圍儲存格值以V陣列值帶入
Application.Goto [Data!A1]
'↑令儲存格游標跳到 [Data!A1]位置
Set Y = Nothing: Erase A, B, V, Z
'↑令釋放變數
End Sub

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