12345
返回列表 上一主題 發帖

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

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
16# 跳轉到 »
發表於 2021-4-14 23:09 | 只看該作者
回復 15# 軒云熊
熊大好,
我把程式稍作修改,以便順應我平日正式檔,程式與執行報表是分開的,但修改後程式就停在
b = xB.Sheets(a3).[a1].SpecialCells(xlCellTypeConstants, 23).Column
無法執行,請幫忙看看！
R0413_1.rar (414.14 KB)

TOP

軒云熊

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

R0413_1.rar (402.34 KB)

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
14#
發表於 2021-4-13 15:15 | 只看該作者
回復 13# 軒云熊

熊大好,

1) 印盤點表...這個工作表完全無法排序,我想是因為第一欄是空白,在第一欄key入某些數字後,就可以正常排序,不知這個能夠克服嗎?如果不行,就不改程式了！
2) 另外,無意中發現若在程式中按F5,則程式也不能排序,但按"sorting"鍵時則可排序,不知原因？

TOP

軒云熊

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

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

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
12#
發表於 2021-4-12 23:14 | 只看該作者
回復 11# 軒云熊
熊大好,
我將目前可能會需要排序的工作表都放入一併測試,如下:
1) 所有工作表,排序的資料下半部不正確
2) 工作表更改過表頭(把表頭範圍加大),排序就更不正確

R0412.rar (393.09 KB)

TOP

軒云熊

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

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

RR0412.rar (300.22 KB)

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
10#
發表於 2021-4-12 00:39 | 只看該作者
回復 9# 軒云熊
不好意思,排序還是會出錯,
"整月統計"的表頭原來在第3列,為了測試用我把上方隨意增減空白列,現在表頭放在第6列,
結果不但排列錯誤,而且會將原來的表頭第2列,移動到下方....
在偵測"料號"的所在位置時,從料號往上的所有列數,都屬於表頭位置,不能列入排序範圍,
不然表格會大亂....再麻煩您了.
RR0409.rar (300.39 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
9#
發表於 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

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
8#
發表於 2021-4-11 22:51 | 只看該作者
回復 7# 軒云熊

熊大好,
反覆測試,它還是無法正確排序,我把正確及錯誤的排列都留在檔案中,
請再幫忙看下....
R0409.rar (423.95 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
7#
發表於 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

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
12345
返回列表 上一主題