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

Public Sub ex()
Dim rng As Range, r%, c%
Sheet3.Range("a1:h" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row).Delete
r = 1
c = 1
For i = 1 To 8 Step 2
Sheet3.Columns(i).ColumnWidth = 9.65
Sheet3.Columns(i + 1).ColumnWidth = 18.13
Next
For Each rng In Sheet1.Range("a2:a" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
With Sheet3
If c < 8 Then
With .Range(.Cells(r, c), .Cells(r + 2, c + 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Font
.Name = "標楷體"
End With
End With
With .Range(.Cells(r, c), .Cells(r, c + 1))
.MergeCells = True
.Value = "XX企業股份有限公司"
With .Font
.Size = 14
End With
End With
.Cells(r + 1, c) = "財產編碼"
.Cells(r + 1, c + 1) = rng
.Cells(r + 2, c) = "品名"
.Cells(r + 2, c + 1) = rng.Offset(, 1)
c = c + 2
End If
If c > 8 Then
c = 1
r = r + 3
End If
End With
Next
End Sub

複製代碼

Sub 轉出()
Dim R&, xR As Range, xH As Range, xE As Range
Call 清除
R = [標籤清單!A65536].End(xlUp).Row
If R < 2 Then Exit Sub
Set xH = [標籤樣式!A4]: Set xE = xH
For Each xR In [標籤清單!A2].Resize(R - 1)
If xH = "" Then [標籤樣式!1:3].Copy xE
xE(2, 2) = xR
xE(3, 2) = xR(1, 2)
Set xE = xE(1, 3)
If xE = "" Then Set xH = xH(4): Set xE = xH
Next
[標籤樣式!1:3].EntireRow.Delete
Application.Goto [標籤樣式!A1]
End Sub

複製代碼

Sub 轉入1()
Dim xA As Range, xB As Range, xR As Range, xH As Range, xE As Range
Call 清除1
Set xA = [清單!C2]: Set xB = [清單!B7]
If xB = "" Then Exit Sub
　
Set xH = [A10]: Set xE = xH '定位資料輸出儲存格位置
Application.ScreenUpdating = False
　
Do: If xH = "" Then Rows("1:8").Copy xH(0, 1) '複製空白樣式
　　xE(2, 1) = xA(1, 1) '填入〔料號〕
　　xE(3, 2) = xA(1, 1) '填入〔料號〕
　　xE(4, 2) = xA(2, 1) '填入〔品名〕
　　xE(4, 4) = xA(4, 1) '填入〔批號〕
　　xE(5, 2) = xB(1, 2) '填入〔高度1〕
　　xE(6, 2) = xB(2, 2) '填入〔高度2〕
　　xE(5, 4) = xB(3, 2) '填入〔高度3〕
　　xE(6, 4) = xB(4, 2) '填入〔高度4〕
　　xE(7, 2) = xB(1, 1) '填入〔盒數〕
　　xE(7, 4) = xB(1, 3) '填入〔備註〕
　　Set xE = xE(1, 6) '定位下一筆填入位置
　　If xE = "" Then Set xH = xH(9): Set xE = xH '若右方已無可填入表格，向下定位
　　Set xB = xB(5, 1) '下一筆資料來源位置
Loop Until xB = ""
　
Rows("1:8").Delete
End Sub
　
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 清除1()
With ActiveSheet
　　.UsedRange.Offset(8, 0).EntireRow.Delete '清除第８列以下資料
　　.[A3,B4,B5:B8,D5:D8] = ""
　　.[A2:E8].Copy [F2:o8]
End With
End Sub

複製代碼