返回列表 上一主題 發帖

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

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

您好,
我有一個"檢核板號.xlsm"讓使用者於A1.A2.A3.A4分別輸入特定資料,每4筆資料為一組。
01.jpg
2022-9-11 23:47

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

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

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

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

您好,
我有一個"檢核板號.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

回復 2# samwang
S大您好,
前文書寫不清楚,我的意思是在F欄~I欄不預設好表頭與公式的前提下,直接將"檢核板號.xlsm"的A欄資料,直接顯示於新檔的A欄~D欄,並存檔。
01.jpg
2022-9-13 11:02

TOP

隨意窩 "EXCEL迷"  blog  或https://blog.xuite.net/hcm19522/twblog
已收集8500篇 EXCEL函數

TOP

回復 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

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

TOP

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

TOP

回復 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

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

TOP

本帖最後由 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

        靜思自在 : 君子如水,隨方就圓,無處不自在。
返回列表 上一主題