excel vba 合併填入資料

Sub tFill()

Application.ScreenUpdating = False

With Sheets("輸入排程")

R = .UsedRange.Rows.Count + 1

If R > 8 Then .Range("9:" & R).Delete

For R = 5 To Sheets("輸入名稱").[D5].End(4).Row

K = (R - 4) * 5 + 4

Sheets("輸入名稱").Cells(R, 4).Resize(, 2).Copy .Cells(K, 4)

2014-11-23 14:13:32 補充：

接上...

Range("D" & K & ":IV" & K + 4).Borders.LineStyle = xlContinuous

.Cells(K, 4).Resize(5).Merge

.Cells(K, 5).Resize(5).Merge

.Cells(K, 4).Resize(5, 6).Interior.ColorIndex = 34

2014-11-23 14:13:52 補充：

接上...

For i = 0 To 4

.Cells(K + i, 7).Resize(, 3).Borders(xlInsideVertical).LineStyle = xlNone

Next

Next

Range("9:" & K + 4).RowHeight = 21

End With

End Sub

2014-11-24 02:30:37 補充：

使用VBA程式碼如下:

Sub tFill()

Application.ScreenUpdating = False

With Sheets("輸入排程")

R = .UsedRange.Rows.Count + 1

If R > 8 Then .Range("9:" & R).Delete

For R = 5 To Sheets("輸入名稱").[D5].End(4).Row

K = (R - 4) * 5 + 4

Sheets("輸入名稱").Cells(R, 4).Resize(, 2).Copy .Cells(K, 4)

.Cells(K, 4).Resize(5).Merge

.Cells(K, 5).Resize(5).Merge

Next

R = K + 4

.Range("9:" & R).RowHeight = 21

.Range("D9:I" & R).Interior.ColorIndex = 34

.Range("D9:IV" & R).Borders.LineStyle = xlContinuous

.Range("G9:I" & R).Borders(xlInsideVertical).LineStyle = xlNone

End With

End Sub

此程式已將意見的程式稍作調整，執行效率較佳

感謝各位大大熱情的幫忙:

每位設計的方法.各有他的巧妙之處.都想選為最佳解答.但沒辦法實在很抱歉.以下還有延伸題可否再幫忙想辦法.謝謝~

https://tw.knowledge.yahoo.com/question/question?q...

以上如果有言詞不當.得罪之處.敬請見諒!

感恩~

Sub 載入()

Dim xR As Range, xE As Range, n&

Call 清除: Set xE = [D14]

For Each xR In Range([輸入名稱!D5], [輸入名稱!D65536].End(xlUp))

　If xR.Row < 5 Then Exit Sub

　Rows("9:13").Copy Rows(xE.Row)

2014-11-23 17:29:54 補充：

　xE = xR: xE(1, 2) = xR(1, 2)

　Set xE = xE(6): n = n + 1

Next

Rows("9:13").EntireRow.Delete

End Sub

參考檔：

http://www.funp.net/954254

2014-11-23 17:51:30 補充：

Sub 載入2()

Dim xR As Range, xE As Range, y&

Call 清除: Set xE = [D9]

y = [輸入名稱!D65536].End(xlUp).Row - 4

If y > 1 Then Rows("9:13").Copy Rows("14:" & y * 5 + 8)

For Each xR In [輸入名稱!D5].Resize(y)

　　xE = xR: xE(1, 2) = xR(1, 2)

　　Set xE = xE(6)

Next

End Sub

http://blog.xuite.net/hcm19522/twblog/259201087

此為函數

請教 大大們 ,若相隔格數E3是變數 ,如何自動跨欄置中 ,為版大所需

Sub 移動()

Dim k, h

h = Sheets("輸入名稱").[A65536].End(xlUp).Row

k = 9

For i = 2 To h

Sheets("輸入排程").Cells(k, 4) = Sheets("輸入名稱").Cells(i, 1)

Sheets("輸入排程").Cells(k, 5) = Sheets("輸入名稱").Cells(i, 2)

k = k + 5

Next i

End Sub

2014-11-23 08:22:53 補充：

Sub 巨集1()

Sheets("輸入排程").Select

Sheets("輸入排程").Cells(9, 4).Select

For i = 2 To Sheets("輸入名稱").[A65536].End(xlUp).Row

ActiveCell.Value = Sheets("輸入名稱").Cells(i, 1)

ActiveCell.Offset(0, 1).Range("A1") = Sheets("輸入名稱").Cells(i, 2)

ActiveCell.Offset(1, 0).Range("A1").Select

Next i

End Sub

2014-11-23 09:19:57 補充：

Sub 巨集1()

Sheets("輸入排程").Select

Cells(9, 4).Select

For i = 5 To Sheets("輸入名稱").[D65536].End(xlUp).Row

ActiveCell.Value = Sheets("輸入名稱").Cells(i, 4)

ActiveCell.Offset(0, 1).Range("A1") = Sheets("輸入名稱").Cells(i, 5)

ActiveCell.Offset(1, 0).Range("A1").Select

Next i

End Sub

2014-11-23 09:21:38 補充：

Sub 移動()

Dim k, h

h = Sheets("輸入名稱").[D65536].End(xlUp).Row

k = 9

For i = 5 To h

Sheets("輸入排程").Cells(k, 4) = Sheets("輸入名稱").Cells(i, 4)

Sheets("輸入排程").Cells(k, 5) = Sheets("輸入名稱").Cells(i, 5)

k = k + 5

Next i

End Sub