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

標題: [發問] Excel 單欄資料轉多欄 [打印本頁]

作者: pointchi 時間: 2022-9-11 23:58 標題: Excel 單欄資料轉多欄

您好，
我有一個"檢核板號.xlsm"讓使用者於A1.A2.A3.A4分別輸入特定資料，每4筆資料為一組。
[attach]35203[/attach]
目前我於F欄~I欄預設好表頭與公式至201列(依經驗最多是50組+表頭1列)，然後執行我錄製並修改過的巨集另存新檔於桌面(檔名邏輯是月月日日-時時分分.xlsx)。
但是這樣每次都要刪除新檔中儲存格值為0的資料，才可以正常列印，不然會浪費很多紙張。
[attach]35205[/attach]
底下是我的巨集代碼：

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
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="C:\Users\Point\OneDrive\桌面\" & M1 & D1 & "-" & H1 & N1 & ".xlsx"
End Sub

複製代碼

請教前輩可以幫我修改成，先判斷C13儲存格是數字(如果不是數字表示輸入資料不完全，則不執行程式)，如是則將"檢核板號.xlsm"的A欄資料，分別丟到新檔的A欄~D欄，並存檔嗎。
感謝。
[attach]35206[/attach]

作者: samwang 時間: 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

作者: pointchi 時間: 2022-9-13 11:03

回復 2# samwang
S大您好，
前文書寫不清楚，我的意思是在F欄~I欄不預設好表頭與公式的前提下，直接將"檢核板號.xlsm"的A欄資料，直接顯示於新檔的A欄~D欄，並存檔。
[attach]35208[/attach]

作者: hcm19522 時間: 2022-9-13 11:10

https://blog.xuite.net/hcm19522/twblog/590537392

作者: Andy2483 時間: 2022-9-13 15:30

回復 1# pointchi

謝謝前輩發表此帖
請試試看

Option Explicit
Sub TEST()
Dim MDHN, i, Arr, Brr
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)
If i Mod 4 Then
Brr(Int(i / 4) + 1, (i Mod 4)) = Arr(i, 1)
Else
Brr(Int(i / 4), 4) = Arr(i, 1)
End If
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

複製代碼

作者: pointchi 時間: 2022-9-14 22:28

回復 4# hcm19522
H大，
我當時的公式也是從您那邊學來的。
而且我常常找資料時也都出現您的BLOG，從您那挖出很多很厲害的公式解法。

作者: pointchi 時間: 2022-9-14 22:30

回復 5# Andy2483
Andy哥，
感謝您的程式支援可以順利執行。

作者: samwang 時間: 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

作者: pointchi 時間: 2022-9-16 11:44

回復 8# samwang
感謝S大，
您的程式碼也可以順利運作。

作者: Andy2483 時間: 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

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