123
返回列表 上一主題 發帖

[發問] 根據"料號欄"為依據,做排序

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
1# 跳轉到 »
發表於 2021-4-8 16:55 | 顯示全部帖子
本帖最後由 軒云熊 於 2021-4-8 17:01 編輯

回復 1# PJChen
有空幫我試試看是不是你要的結果 會很慢因為迴圈太多了 看看有沒有大大願意幫忙 感謝
  1. Public Sub 跨工作簿比對並移動練習()
  2.     Application.ScreenUpdating = False
  3.    
  4.     Sheets.Copy After:=Sheets(Sheets.Count)
  5.     For X = [H65535].End(3).Row To 1 Step -1
  6.         If IsError(Cells(X, "H")) Then
  7.             Rows(X).Delete
  8.         End If
  9.     Next X
  10.     Range([A65535].End(3), [A4]).Sort [A4], 1, Header:=2
  11.    
  12.    
  13.     Set xD = CreateObject("Scripting.Dictionary")
  14.     Arr = Range([A65535].End(3), [A1])
  15.    
  16.     Application.DisplayAlerts = False
  17.     Sheets(Sheets.Count).Delete
  18.     Application.DisplayAlerts = True
  19.    
  20.     For X = 1 To UBound(Arr, 1)
  21.             xD(Arr(X, 1)) = Trim(xD(Arr(X, 1)) & " " & X)
  22.     Next X
  23.     Erase Arr
  24.    
  25.     A = Dir("T:\0_自訂表單\日常表格\*.xlsx")
  26.     Workbooks.Open "T:\0_自訂表單\日常表格\" & A & ""
  27.     Set W = Workbooks("商品2.xlsm").Sheets(1)
  28.    
  29.     For E = 1 To Sheets.Count
  30.         N = Sheets(E).Name: Sheets(E).Activate
  31.         If IsNumeric(N) Then
  32.             If Int(N) > W.[M2] Then Exit For
  33.             If Int(N) >= W.[M1] And Int(N) <= W.[M2] Then
  34.                 Arr = ActiveSheet.UsedRange
  35.                 For X = 1 To UBound(Arr, 1)
  36.                     For Y = 1 To UBound(Arr, 2)
  37.                         If Arr(X, Y) = "料號" Then
  38.                             Brr = Range(Cells(1, Y), Cells(Rows.Count, Y).End(3))
  39.                             GoTo A01
  40.                         End If
  41.                     Next Y
  42.                 Next X
  43. A01:            Y = Y: Erase Arr
  44.                
  45.                 For Each D In xD
  46.                 SR = Split(xD(D), " ")
  47.                     For Each S In SR
  48.                         SInt = Int(S)
  49.                         For Z = UBound(Brr) To 1 Step -1
  50.                         On Error Resume Next
  51.                             If D <> Empty Then
  52.                                 If D = Brr(Z, 1) Then
  53.                                     Rows(Z).Cut
  54.                                     Rows(SInt).Insert , 1
  55.                                     Brr = Range(Cells(1, Y), Cells(Rows.Count, Y).End(3))
  56.                                     Exit For
  57.                                 End If
  58.                             End If
  59.                         On Error GoTo 0
  60.                         Next Z
  61.                     Next S
  62.                 Next D
  63.         
  64.             End If
  65.         End If
  66.     Next E
  67.    
  68.     Application.ScreenUpdating = True
  69. End Sub
複製代碼
商品20408.rar (38.23 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
2#
發表於 2021-4-9 00:22 | 顯示全部帖子
回復 4# PJChen

    For E = 1 To Sheets.Count
        N = Sheets(E).Name: Sheets(E).Activate
        If IsNumeric(N) Then
            If Int(N) > W.[M2] Then Exit For
            If Int(N) >= W.[M1] And Int(N) <= W.[M2] Then
可以改成
    For E = 1 To Sheets.Count
        Sheets(E).Activate
        If E > W.[M2] Then Exit For
        If E >= W.[M1] And E <= W.[M2] Then

這段
    For X = [H65535].End(3).Row To 1 Step -1
        If IsError(Cells(X, "H")) Then
            Rows(X).Delete
        End If
    Next X
    Range([A65535].End(3), [A4]).Sort [A4], 1, Header:=2

是用 H欄 做排序後的依據 因為可以排除沒有的資料
或著 你可以改成

    Sheets.Copy After:=Sheets(Sheets.Count)
    For X = [H65535].End(3).Row To 1 Step -1
        If IsError(Cells(X, "A")) Then
            Rows(X).Delete
        End If
    Next X
    Range([A65535].End(3), [A4]).Sort [A4], 1, Header:=2
其實也沒差 因為 If D = Brr(Z, 1) Then 已經可以跳過了

我有稍微修改了一下這段

            For Each D In xD
                SR = Split(xD(D), " ")
                For Each S In SR
                    SInt = Int(S)
                    If D = Empty Then Exit For
                    With Range(Cells(1, Y), Cells(Rows.Count, Y).End(3))
                        On Error Resume Next
                        Set C = .Find(D)
                        G = .FindNext(C).Address
                        If C = D Then
                            If Not C Is Nothing Then
                                Rows(C.Row).Cut
                                Set C = .FindNext(G)
                                Rows(SInt).Insert , 1
                            End If
                        End If
                        On Error GoTo 0
                    End With
                Next S
            Next D


但還是很慢 ..如果資料量大會非常慢... .看看有沒有大大可以幫忙

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
3#
發表於 2021-4-10 00:39 | 顯示全部帖子
回復 6# PJChen

有空再幫我試試看是不是你要的結果謝謝
  1. Public Sub 跨工作簿比對並移動練習0409()
  2.     Application.ScreenUpdating = False
  3.     '新增一個工作表排列後 存到陣列在刪除工作表
  4.     Sheets.Copy After:=Sheets(Sheets.Count)
  5.     Range([A65535].End(3), [A4]).Sort [A4], 1, Header:=2

  7.     Set xD = CreateObject("Scripting.Dictionary")
  8.     Arr = Range([A65535].End(3), [A1])
  9.    
  10.     Application.DisplayAlerts = False
  11.     Sheets(Sheets.Count).Delete
  12.     Application.DisplayAlerts = True
  13. '--------------------------------------------------------
  14.     '把排列後的資料存到字典裡
  15.     For X = 1 To UBound(Arr, 1)
  16.         xD(Arr(X, 1)) = Trim(xD(Arr(X, 1)) & " " & X)
  17.     Next X
  18.     Erase Arr
  19. '--------------------------------------------------------
  20.     '尋找檔案的位置然後開啟
  21.     A = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
  22.     Workbooks.Open ThisWorkbook.Path & "\" & A
  23. '--------------------------------------------------------
  24.     '切換到指定工作表 把含有"料號"的那一欄位置記下來
  25.     Sheets("整月統計").Activate '這裡可以指定要排列的工作表的位置 "整月統計" 或 "3"
  26.     Arr = ActiveSheet.UsedRange
  27.     For X = 1 To UBound(Arr, 1)
  28.         For Y = 1 To UBound(Arr, 2)
  29.             If Arr(X, Y) = "料號" Then
  30.                 Y = Y
  31.                 X = X + 1
  32.                 GoTo A01
  33.             End If
  34.         Next Y
  35.     Next X
  36. A01: Erase Arr
  37. '--------------------------------------------------------
  38.     '尋找比對後並重新排列
  39.     For Each D In xD
  40.         SR = Split(xD(D), " ")
  41.         For Each S In SR
  42.             If D = Empty Then Exit For
  43.             With Range(Cells(1, Y), Cells(Rows.Count, Y).End(3))
  44.                 On Error Resume Next
  45.                 Set C = .Find(D)
  46.                 G = .FindNext(C).Address
  47.                 If C = D Then
  48.                     If Not C Is Nothing Then
  49.                         Rows(C.Row).Cut
  50.                         Set C = .FindNext(G)
  51.                         K = K + 1
  52.                         Rows(X + K).Insert , 1
  53.                     End If
  54.                 End If
  55.                 Application.CutCopyMode = False
  56.                 On Error GoTo 0
  57.             End With
  58.         Next S
  59.     Next D
  60.     Set C = Nothing
  61.    
  62.     Application.ScreenUpdating = True
  63. End Sub
複製代碼
0409.rar (287.7 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
4#
發表於 2021-4-12 00:09 | 顯示全部帖子
回復 8# PJChen


我以為你要重新排列 所以才會加入這段
    '新增一個工作表排列後 存到陣列在刪除工作表
把這些刪除再試試看 是不是你要的結果 感謝
'    Sheets.Copy After:=Sheets(Sheets.Count)
'    Range([A65535].End(3), [A4]).Sort [A4], 1, Header:=2

    Set xD = CreateObject("Scripting.Dictionary")
    Arr = Range([A65535].End(3), [A1])
   
'    Application.DisplayAlerts = False
'    Sheets(Sheets.Count).Delete
'    Application.DisplayAlerts = True

保留
    Set xD = CreateObject("Scripting.Dictionary")
    Arr = Range([A65535].End(3), [A1])

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
5#
發表於 2021-4-12 22:19 | 顯示全部帖子
回復 10# PJChen

我有修改過了  有空再幫我試試看 行不行 感謝

RR0412.rar (300.22 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
6#
發表於 2021-4-13 01:13 | 顯示全部帖子
回復 12# PJChen

改好了 有空再看看是不是你要的結果 感謝
R0413.rar (401.45 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
7#
發表於 2021-4-13 22:08 | 顯示全部帖子
回復 14# PJChen
我也不知道 F5 的問題 >"<     有空在幫我試試看 還有沒有問題 感謝

R0413_1.rar (402.34 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
8#
發表於 2021-4-15 02:05 | 顯示全部帖子
回復 16# PJChen

可以把要修改的 步驟寫出來

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
9#
發表於 2021-4-15 17:08 | 顯示全部帖子
回復 16# PJChen

有空再幫我試試看 是不是你要的結果 感謝

R0415.rar (411.68 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
10#
發表於 2021-4-15 22:25 | 顯示全部帖子
回復 16# PJChen

這是有加入多個活頁簿循環和單一活頁簿看要用哪一個  看看這樣行不行 也許可以存成增益集
0415_1.rar (22.33 KB)

TOP

        靜思自在 : 要比誰更受誰．不要比誰更怕誰。
123
返回列表 上一主題