返回列表 上一主題 發帖

[發問] Excel 單欄資料轉多欄

pointchi

帖子
18 
主題
5 
精華
0 
積分
73 
點名
0  
作業系統
Window XP 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2016-8-2 
最後登錄
2024-11-27 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2022-9-11 23:58 | 只看該作者

[發問] Excel 單欄資料轉多欄

您好，
我有一個"檢核板號.xlsm"讓使用者於A1.A2.A3.A4分別輸入特定資料，每4筆資料為一組。

目前我於F欄~I欄預設好表頭與公式至201列(依經驗最多是50組+表頭1列)，然後執行我錄製並修改過的巨集另存新檔於桌面(檔名邏輯是月月日日-時時分分.xlsx)。
但是這樣每次都要刪除新檔中儲存格值為0的資料，才可以正常列印，不然會浪費很多紙張。

底下是我的巨集代碼：
  1. Sub Step01()

  3. M1 = Format(Now, "MM")
  4. D1 = Format(Now, "DD")
  5. H1 = Format(Now, "HH")
  6. N1 = Format(Now, "NN")

  8.     Columns("F:I").Select
  9.     Selection.Copy
  10.     Workbooks.Add
  11.     Columns("A:A").Select
  12.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  13.         :=False, Transpose:=False
  14.     Application.CutCopyMode = False
  15.     ActiveWorkbook.SaveAs Filename:="C:\Users\Point\OneDrive\桌面\" & M1 & D1 & "-" & H1 & N1 & ".xlsx"
  16. End Sub
複製代碼
請教前輩可以幫我修改成，先判斷C13儲存格是數字(如果不是數字表示輸入資料不完全，則不執行程式)，如是則將"檢核板號.xlsm"的A欄資料，分別丟到新檔的A欄~D欄，並存檔嗎。
感謝。
檢核板號.rar (24.68 KB)
收藏 分享

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1478 
主題
40 
精華
0 
積分
1502 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2025-10-23 
10#
發表於 2022-9-17 10:19 | 只看該作者
本帖最後由 Andy2483 於 2022-9-17 10:21 編輯

回復 7# pointchi


    謝謝前輩回覆
    謝謝samwang前輩指導
再習得 IIf( )  取代  if ~else~

Option Explicit
Sub TEST1()
Dim MDHN, i, Arr, Brr, R, C
MDHN = Format(Now, "MMDD-HHNN")
Arr = Range([A1], Cells(Rows.Count, "A").End(3))
ReDim Brr(1 To UBound(Arr) / 4, 1 To 4)
For i = 1 To UBound(Arr)
   C = IIf(i Mod 4, i Mod 4, 4)
   R = IIf(C = 1, R + 1, R)
   Brr(R, C) = Arr(i, 1)
Next
Workbooks.Add
[A1].Resize(1, 4) = Array("料號", "數量", "板號", "儲位")
[A2].Resize(UBound(Brr), 4) = Brr
[A:D].Columns.AutoFit
ActiveWorkbook.SaveAs Filename:="C:\Users\Point\OneDrive\桌面\" & MDHN & ".xlsx"
End Sub

TOP

pointchi

帖子
18 
主題
5 
精華
0 
積分
73 
點名
0  
作業系統
Window XP 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2016-8-2 
最後登錄
2024-11-27 
9#
發表於 2022-9-16 11:44 | 只看該作者
回復 8# samwang
感謝S大，
您的程式碼也可以順利運作。

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-8-22 
8#
發表於 2022-9-15 12:40 | 只看該作者
回復 3# pointchi

借用Andy2483前賢程式碼，修改一下，請測試看看，謝謝
Sub test()
Dim MDHN, i&, Arr, Brr, R&, C%
MDHN = Format(Now, "MMDD-HHNN")
Arr = Range([A1], Cells(Rows.Count, "A").End(3))
ReDim Brr(1 To UBound(Arr) / 4, 1 To 4)
For i = 1 To UBound(Arr)
    C = C + 1: Brr(R + 1, C) = Arr(i, 1)
    If C = 4 Then C = 0: R = R + 1
Next
Workbooks.Add
[A1].Resize(1, 4) = Array("料號", "數量", "板號", "儲位")
[A2].Resize(UBound(Brr), 4) = Brr
[A:D].Columns.AutoFit
ActiveWorkbook.SaveAs Filename:="C:\Users\Point\OneDrive\桌面\" & MDHN & ".xlsx"
End Sub

TOP

pointchi

帖子
18 
主題
5 
精華
0 
積分
73 
點名
0  
作業系統
Window XP 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2016-8-2 
最後登錄
2024-11-27 
7#
發表於 2022-9-14 22:30 | 只看該作者
回復 5# Andy2483
Andy哥，
感謝您的程式支援可以順利執行。

TOP

pointchi

帖子
18 
主題
5 
精華
0 
積分
73 
點名
0  
作業系統
Window XP 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2016-8-2 
最後登錄
2024-11-27 
6#
發表於 2022-9-14 22:28 | 只看該作者
回復 4# hcm19522
H大，
我當時的公式也是從您那邊學來的。
而且我常常找資料時也都出現您的BLOG，從您那挖出很多很厲害的公式解法。

TOP

Andy2483
　暱稱: 厚臉皮的學生

碩士班Rank: 5Rank: 5

帖子
1478 
主題
40 
精華
0 
積分
1502 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
100 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2025-10-23 
5#
發表於 2022-9-13 15:30 | 只看該作者
回復 1# pointchi


    謝謝前輩發表此帖
請試試看
  1. Option Explicit
  2. Sub TEST()
  3. Dim MDHN, i, Arr, Brr
  4. MDHN = Format(Now, "MMDD-HHNN")
  5. Arr = Range([A1], Cells(Rows.Count, "A").End(3))
  6. ReDim Brr(1 To UBound(Arr) / 4, 1 To 4)
  7. For i = 1 To UBound(Arr)
  8.    If i Mod 4 Then
  9.       Brr(Int(i / 4) + 1, (i Mod 4)) = Arr(i, 1)
  10.       Else
  11.          Brr(Int(i / 4), 4) = Arr(i, 1)
  12.    End If
  13. Next
  14. Workbooks.Add
  15. [A1].Resize(1, 4) = Array("料號", "數量", "板號", "儲位")
  16. [A2].Resize(UBound(Brr), 4) = Brr
  17. [A:D].Columns.AutoFit
  18. ActiveWorkbook.SaveAs Filename:="C:\Users\Point\OneDrive\桌面\" & MDHN & ".xlsx"
  19. End Sub
複製代碼

TOP

hcm19522

帖子
1437 
主題
11 
精華
0 
積分
1454 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2025-10-24 

熱烈參與勳章
4#
發表於 2022-9-13 11:10 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/590537392
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

pointchi

帖子
18 
主題
5 
精華
0 
積分
73 
點名
0  
作業系統
Window XP 
軟體版本
OFFICE 2003 
閱讀權限
20 
註冊時間
2016-8-2 
最後登錄
2024-11-27 
3#
發表於 2022-9-13 11:03 | 只看該作者
回復 2# samwang
S大您好，
前文書寫不清楚，我的意思是在F欄~I欄不預設好表頭與公式的前提下，直接將"檢核板號.xlsm"的A欄資料，直接顯示於新檔的A欄~D欄，並存檔。

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-8-22 
2#
發表於 2022-9-12 16:38 | 只看該作者
您好，
我有一個"檢核板號.xlsm"讓使用者於A1.A2.A3.A4分別輸入特定資料，每4筆資料為一組。

目前我於F ...
pointchi 發表於 2022-9-11 23:58


新增如下，請測試看看，謝謝

Sub Step01()

M1 = Format(Now, "MM")
D1 = Format(Now, "DD")
H1 = Format(Now, "HH")
N1 = Format(Now, "NN")

    Columns("F:I").Select
    Selection.Copy
    Workbooks.Add
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
Dim xR As Range, xU As Range
For Each xR In ActiveSheet.Range("C:C").SpecialCells(xlCellTypeConstants).Rows
    If Not IsError(Application.Match(0, xR, 0)) Then
        If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
     End If
Next
If Not xU Is Nothing Then xU.EntireRow.Delete

   
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:="C:\Users\Point\OneDrive\桌面\" & M1 & D1 & "-" & H1 & N1 & ".xlsx"
End Sub

TOP

        靜思自在 : 滴水成河。粒米成蘿，勿輕己靈，勿以善小而不為。
返回列表 上一主題