英文:
VBA Loop to fill a table
问题
I wanted to write a macro to fill a table on Sheet2 using data in Sheet1.
我想编写一个宏，用来使用Sheet1中的数据填充Sheet2上的表格。
I will first count the number of periods in Sheet1, and then in Sheet2, there are 3 rows that need to be filled using data in Sheet1 for each period.
我首先会在Sheet1中计算周期的数量，然后在Sheet2中，每个周期需要用Sheet1中的数据填充3行。
The code that I wrote is not working correctly to fill the table. I wasn't able to figure out the right way to solve this. Can anyone please help? Thank you in advance!
我编写的代码不能正确地填充表格。我无法找到正确的解决方法。请有人可以帮助吗？提前谢谢！
英文:
I wanted to write a macro to fill a table on Sheet2 using data in Sheet1.
I will first count the number of period in Sheet1, and then in Sheet2, there are 3 rows that need to be filled using data in Sheet1 for each period. The rule can be seen from the labeled color.
The code that I wrote is not working correctly to fill the table. I wasn't able to figure out the right way to solve this. Can anyone please help？ Thank you in advance!
Sub fillDate()
Dim periods As Long, i As Integer, j As Integer
periods = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row - 7
For i = 2 To 2 + (periods - 1) * 3 Step 3
For j = 1 To periods
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(0, 0).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 0).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(0, 1).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 0).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(0, 2).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 0).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(0, 3).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 3).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(1, 0).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 0).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(1, 1).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 0).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(1, 2).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 2).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(1, 3).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 3).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(2, 0).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 2).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(2, 1).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 2).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(2, 2).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 2).Value
ThisWorkbook.Sheets("Sheet2").Range("A" & i).Offset(2, 3).Value = ThisWorkbook.Sheets("Sheet1").Range("F7").Offset(j, 3).Value
Next j
Next i
End Sub
答案1
得分: 2
以下是您要翻译的代码部分：
Sub ReArrangeData()
' 定义常量。
Const SRC_SHEET As String = "Sheet1"
Const SRC_FIRST_CELL As String = "E7"
Dim sArr(): sArr = VBA.Array( _
VBA.Array(2, 2, 2, 5, 1), _
VBA.Array(2, 2, 4, 5, 1), _
VBA.Array(4, 4, 4, 5, 1))
Const DST_SHEET As String = "Sheet2"
Const DST_FIRST_CELL As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook
' 将源数据写入数组。
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
Dim sData(), srCount As Long
With sws.Range(SRC_FIRST_CELL).CurrentRegion
srCount = .Rows.Count - 1
sData = .Resize(srCount).Offset(1).Value
End With
' 将重新排列的数据返回到另一个数组中。
Dim rUpper As Long: rUpper = UBound(sArr)
Dim cUpper As Long: cUpper = UBound(sArr(0))
Dim dcCount As Long: dcCount = cUpper + 1
Dim dData(): ReDim dData(1 To srCount * (rUpper + 1), 1 To dcCount)
Dim sr As Long, dr As Long, r As Long, c As Long
For sr = 1 To srCount
For r = 0 To rUpper
dr = dr + 1
For c = 0 To cUpper
dData(dr, c + 1) = sData(sr, sArr(r)(c))
Next c
Next r
Next sr
' 将重新排列的数据写入目标范围。
Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
Dim drg As Range:
Set drg = dws.Range(DST_FIRST_CELL).Resize(dr, dcCount)
drg.Value = dData
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
' 提示信息。
MsgBox "数据重新排列。", vbInformation
End Sub
希望这能帮助您。如果您需要进一步的翻译或有其他问题，请告诉我。
英文:
Rearrange Data
<!-- language: lang-vb -->
Sub ReArrangeData()
' Define constants.
Const SRC_SHEET As String = "Sheet1"
Const SRC_FIRST_CELL As String = "E7"
Dim sArr(): sArr = VBA.Array( _
VBA.Array(2, 2, 2, 5, 1), _
VBA.Array(2, 2, 4, 5, 1), _
VBA.Array(4, 4, 4, 5, 1))
Const DST_SHEET As String = "Sheet2"
Const DST_FIRST_CELL As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the source data to an array.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
Dim sData(), srCount As Long
With sws.Range(SRC_FIRST_CELL).CurrentRegion
srCount = .Rows.Count - 1
sData = .Resize(srCount).Offset(1).Value
End With
' Return the rearranged data in another array.
Dim rUpper As Long: rUpper = UBound(sArr)
Dim cUpper As Long: cUpper = UBound(sArr(0))
Dim dcCount As Long: dcCount = cUpper + 1
Dim dData(): ReDim dData(1 To srCount * (rUpper + 1), 1 To dcCount)
Dim sr As Long, dr As Long, r As Long, c As Long
For sr = 1 To srCount
For r = 0 To rUpper
dr = dr + 1
For c = 0 To cUpper
dData(dr, c + 1) = sData(sr, sArr(r)(c))
Next c
Next r
Next sr
' Write the rearranged data to the destination range.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
Dim drg As Range:
Set drg = dws.Range(DST_FIRST_CELL).Resize(dr, dcCount)
drg.Value = dData
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
' Inform.
MsgBox "Data rearranged.", vbInformation
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论