匯入總表數據bug

waitto04

各位大大好，初來乍到想詢問一個程式語言
小弟遇到狀況如下
1.將5個專案分別以複製方式貼上"經管表格" (OK)
2.貼上後再將C欄選取範圍匯入"總表" (不OK)
不OK的原因是...
當匯入過去後，全部數值會變成一樣的(求解)
因為寫的這個程式碼感覺很暴力，是否有比較簡單的寫法?(求解)

以下是程式碼，再麻煩各位協助除錯!!! 感恩感恩
Sub summary2()

    工作表1.Activate
   
    'If Sheet <> 專案 Then Exit Sub '非有專案的標題 不動作
    For j = 3 To 7
        For i = 2 To 6
        
           Range("B3:D58").ClearContents
           Sheets(j).Range("B3:D58").Copy Destination:=[b3]
   
               
            工作表7.Cells(4, i) = [c3]
            工作表7.Cells(5, i) = [c5]
            工作表7.Cells(6, i) = [c6]
            工作表7.Cells(7, i) = [c7]
            工作表7.Cells(8, i) = [c8]
            工作表7.Cells(9, i) = [c9]
            工作表7.Cells(10, i) = [c10]
            工作表7.Cells(11, i) = [c11]
            工作表7.Cells(12, i) = [c12]
            工作表7.Cells(13, i) = [c13]
            工作表7.Cells(14, i) = [c14]
            工作表7.Cells(15, i) = [c15]
            工作表7.Cells(16, i) = [c16]
            工作表7.Cells(17, i) = [c17]
            工作表7.Cells(18, i) = [c18]
            工作表7.Cells(19, i) = [c19]
            工作表7.Cells(20, i) = [c20]
            工作表7.Cells(21, i) = [c21]
            工作表7.Cells(22, i) = [c22]
            工作表7.Cells(23, i) = [c23]
            工作表7.Cells(24, i) = [c24]
            工作表7.Cells(25, i) = [c25]
            工作表7.Cells(26, i) = [c26]
            工作表7.Cells(27, i) = [c27]
            工作表7.Cells(28, i) = [c28]
            工作表7.Cells(29, i) = [c29]
            工作表7.Cells(30, i) = [c30]
            工作表7.Cells(31, i) = [c31]
            工作表7.Cells(32, i) = [c32]
            工作表7.Cells(33, i) = [c33]
            工作表7.Cells(34, i) = [c34]
            工作表7.Cells(35, i) = [c35]
            工作表7.Cells(36, i) = [c36]
            工作表7.Cells(37, i) = [c37]
            工作表7.Cells(38, i) = [c38]
            工作表7.Cells(39, i) = [c39]
            工作表7.Cells(40, i) = [c40]
            工作表7.Cells(41, i) = [c41]
            工作表7.Cells(42, i) = [c42]
            工作表7.Cells(43, i) = [c43]
            工作表7.Cells(44, i) = [c44]
            工作表7.Cells(45, i) = [c45]
            工作表7.Cells(46, i) = [c46]
            工作表7.Cells(47, i) = [c47]
            工作表7.Cells(48, i) = [c48]
            工作表7.Cells(49, i) = [c49]
            工作表7.Cells(50, i) = [c50]
            工作表7.Cells(51, i) = [c51]
            工作表7.Cells(52, i) = [c52]
            工作表7.Cells(53, i) = [c53]
            工作表7.Cells(54, i) = [c54]
            工作表7.Cells(55, i) = [c55]
            工作表7.Cells(56, i) = [c56]
            工作表7.Cells(57, i) = [c57]
            工作表7.Cells(58, i) = [c58]
            
           
         Next
    Next
   
    工作表7.Activate
   
   

End Sub

samwang

回復 1# waitto04

方便附上檔案，謝謝

waitto04

回復 2# samwang


    請參考!!  謝謝!!
    模組主要放在modul1

waitto04

寫出了另一個可以導入的
結果變成了B欄被跳過了...悲劇...

Sub test()

    工作表1.Activate
    Set i = 工作表1.Range("C5:C58")
        For j = 2 To 7
        
           Range("B358").ClearContents
           Sheets(j).Range("B358").Copy Destination:=[b3]
        
               
            工作表7.Cells(4, j) = [c3]
            工作表7.Cells(5, j) = [c5]
            工作表7.Cells(6, j) = [c6]
            工作表7.Cells(7, j) = [c7]
            工作表7.Cells(8, j) = [c8]
            工作表7.Cells(9, j) = [c9]
            工作表7.Cells(10, j) = [c10]
            工作表7.Cells(11, j) = [c11]
            工作表7.Cells(12, j) = [c12]
            工作表7.Cells(13, j) = [c13]
            工作表7.Cells(14, j) = [c14]
            工作表7.Cells(15, j) = [c15]
            工作表7.Cells(16, j) = [c16]
            工作表7.Cells(17, j) = [c17]
            工作表7.Cells(18, j) = [c18]
            工作表7.Cells(19, j) = [c19]
            工作表7.Cells(20, j) = [c20]
            工作表7.Cells(21, j) = [c21]
            工作表7.Cells(22, j) = [c22]
            工作表7.Cells(23, j) = [c23]
            工作表7.Cells(24, j) = [c24]
            工作表7.Cells(25, j) = [c25]
            工作表7.Cells(26, j) = [c26]
            工作表7.Cells(27, j) = [c27]
            工作表7.Cells(28, j) = [c28]
            工作表7.Cells(29, j) = [c29]
            工作表7.Cells(30, j) = [c30]
            工作表7.Cells(31, j) = [c31]
            工作表7.Cells(32, j) = [c32]
            工作表7.Cells(33, j) = [c33]
            工作表7.Cells(34, j) = [c34]
            工作表7.Cells(35, j) = [c35]
            工作表7.Cells(36, j) = [c36]
            工作表7.Cells(37, j) = [c37]
            工作表7.Cells(38, j) = [c38]
            工作表7.Cells(39, j) = [c39]
            工作表7.Cells(40, j) = [c40]
            工作表7.Cells(41, j) = [c41]
            工作表7.Cells(42, j) = [c42]
            工作表7.Cells(43, j) = [c43]
            工作表7.Cells(44, j) = [c44]
            工作表7.Cells(45, j) = [c45]
            工作表7.Cells(46, j) = [c46]
            工作表7.Cells(47, j) = [c47]
            工作表7.Cells(48, j) = [c48]
            工作表7.Cells(49, j) = [c49]
            工作表7.Cells(50, j) = [c50]
            工作表7.Cells(51, j) = [c51]
            工作表7.Cells(52, j) = [c52]
            工作表7.Cells(53, j) = [c53]
            工作表7.Cells(54, j) = [c54]
            工作表7.Cells(55, j) = [c55]
            工作表7.Cells(56, j) = [c56]
            工作表7.Cells(57, j) = [c57]
            工作表7.Cells(58, j) = [c58]
        
    Next
   
    工作表7.Activate
   
    'Columns("B:B").Delete
   
   

End Sub

samwang

回復 3# waitto04

請測試看看，謝謝

Sub test()
Dim Arr, xD, T$, i&, j%
Set xD = CreateObject("Scripting.Dictionary")
For Each sh In Sheets
    If InStr(sh.Name, "專案") Then
        With sh
            Arr = .[a1].CurrentRegion
            For i = 5 To UBound(Arr)
                If Arr(i, 3) = "" Then GoTo 90
                T = sh.Name & "|" & Arr(i, 1)
                xD(T) = Arr(i, 3)
90:         Next
        End With
    End If
Next
With Sheets(1)
    [b5:f58] = ""
    Arr = .[a1].CurrentRegion
    For i = 5 To UBound(Arr): For j = 2 To UBound(Arr, 2)
        T = Arr(4, j) & "|" & Arr(i, 1)
        Arr(i, j) = xD(T)
    Next: Next
    .[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End With
End Sub

waitto04

回復 5# samwang


   
這個沒辦法作業...
沒有bug 但是總表沒有生成

samwang

回復  samwang


   
這個沒辦法作業...
沒有bug 但是總表沒有生成
waitto04 發表於 2022-5-29 09:59

我測試沒問題如附件，比對條件如照片(工作表名稱+項目)有符合就帶入數據，
請再測試看看，謝謝

waitto04

回復 7# samwang


    感謝你不厭其煩的測試!!
但沒辦法成功引入...反而原有的"經管表格"內容也被清空了!!
有定義作用頁面是在哪個嗎?

samwang

回復  samwang


    感謝你不厭其煩的測試!!
但沒辦法成功引入...反而原有的"經管表格"內容也被清空了 ...
waitto04 發表於 2022-5-29 10:40

反而原有的"經管表格"內容也被清空了
>> 對不起，清除總表資料[b5:f58] = ""，前面少了. 請自行加入，我也把程式附上說明，請再自己確認一下，謝謝

Sub test()
Dim Arr, xD, T$, i&, j%
Set xD = CreateObject("Scripting.Dictionary")
For Each sh In Sheets
    If InStr(sh.Name, "專案") Then '工作名稱有專案
        With sh
            Arr = .[a1].CurrentRegion '資料裝入數組
            For i = 5 To UBound(Arr)
                If Arr(i, 3) = "" Then GoTo 90 '沒數據離開
                T = sh.Name & "|" & Arr(i, 1)  '條件:工作表名稱+項目
                xD(T) = Arr(i, 3)              '數據裝入字典
90:         Next
        End With
    End If
Next
With Sheets(1)
   .[b5:f58] = "" '清除原有數據資料，前面原來漏掉  .   ，請自行修改
    Arr = .[a1].CurrentRegion  '資料裝入數組
    For i = 5 To UBound(Arr): For j = 2 To UBound(Arr, 2)
        T = Arr(4, j) & "|" & Arr(i, 1) '條件:工作表名稱+項目
        Arr(i, j) = xD(T) '匯出字典數據
    Next: Next
    .[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr '數據回填到excel
End With
End Sub

waitto04

回復 9# samwang


  有點想哭!
是因為版本不同的關係所以有所差別??
因為真的帶不出來...