第一個名稱被“分組”為 A2:C7。從該范圍內，我希望在 B 列中復制粘貼姓名、作業以及第二和第五個數字。然后這將回圈用于下一個人員和作業職能。附上一些背景關系截圖：
資料轉儲
期望的輸出
Sub DailyCumulations2()
Dim row As Long
Dim lastrow1 As Long, lastrow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Data Dump")
Set ws2 = Worksheets("Daily Cumulations")
lastrow1 = ws1.Range("B" & Cells.Rows.count).End(xlUp).row
For row = 1 To lastrow1
If Excel.WorksheetFunction.IsText(ws1.Range("B" & row).Value)
Then
ws2.Range("A" & row).Value = ws1.Range("B" & row).Value
ws2.Range("B" & row).Value = ws1.Range("A" & row).Value
ws2.Cells(row 1, 3).Value = ws1.Cells(row 5, 2).Value
ws2.Cells(row 1, 4).Value = ws1.Cells(row 2, 2).Value
End If
Next
ws2.Range("A" & row).SpecialCells(xlCellTypeBlanks).DeleteShift:=xlUp
End Sub
uj5u.com熱心網友回復：
VBA 真的是合適的工具嗎？公式在 Excel 中通常更合適，并且拖動（有間隙）可以做很多事情。您能否修改問題以顯示起點和期望的結果，以便我們可以查看是否有非 VBA 解決方案？
uj5u.com熱心網友回復：
像這樣的東西可能會起作用（假設你的塊都是相同的大小并且從同一個地方開始）
Sub DailyCumulations2()
Dim rng As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Data Dump")
Set ws2 = Worksheets("Daily Cumulations")
Set rng = ws1.Range("A2:B7")
Do While Len(rng.Cells(1).Value) > 0 'while there's content...
'next empty row on ws2
With ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1).EntireRow
'populate data for this row
.Cells(1).Resize(1, 4).Value = Array(rng.Cells(1, 1).Value, _
rng.Cells(1, 2).Value, _
rng.Cells(3, 2).Value, _
rng.Cells(6, 2).Value)
End With
Set rng = rng.Offset(rng.Rows.Count, 0) 'next block down
Loop
End Sub
uj5u.com熱心網友回復：
從資料組復制
- 源資料的第二個螢屏截圖顯示資料在行方面不一致，因此存在一些復雜性。
- 大多數剩余的復雜性是由于使代碼動態化。
- 調整（使用）常量部分中的值。
Option Explicit
Sub CopyDailyCumulations()
' Source
Const sName As String = "Data Dump"
Const sfCol As String = "A"
Const sfRow As Long = 1
Const sTextColOffset As Long = 1
Const sNumbersCount As Long = 5
Dim sRowOffsets As Variant: sRowOffsets = VBA.Array(0, 0, 2, 5)
Dim sColOffsets As Variant: sColOffsets = VBA.Array(0, 1, 1, 1)
' Destination
Const dName As String = "Daily Cumulations"
Const dfCol As String = "A"
Const dfRow As Long = 2
Dim dColOffsets As Variant: dColOffsets = VBA.Array(1, 0, 3, 2)
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet and calculate the last row.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row
' Reference the destination worksheet, the destination first cell
' and calculate the number of rows from the first cell to the bottom.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Cells(dfRow, dfCol)
Dim dwsrCount As Long: dwsrCount = dws.Rows.Count - dfCell.Row 1
' Clear the destination column data.
Dim oUpper As Long: oUpper = UBound(dColOffsets)
Dim o As Long
For o = 0 To oUpper
dfCell.Offset(, dColOffsets(o)).Resize(dwsrCount).Clear
Next o
' Write the values from the source to the destination worksheet.
Dim sCell As Range
Dim sr As Long
Dim dCell As Range
Dim ddrCount As Long
For sr = sfRow To slRow
Set sCell = sws.Cells(sr, sfCol)
If Not IsNumeric(sCell.Offset(, sTextColOffset)) Then ' not numeric
ddrCount = ddrCount 1
For o = 0 To oUpper
dfCell.Offset(, dColOffsets(o)).Value _
= sCell.Offset(sRowOffsets(o), sColOffsets(o)).Value
Next o
Set dfCell = dfCell.Offset(1)
sr = sr sNumbersCount
'Else ' the cell value is a number or is empty (also numeric in vBA)
End If
Next sr
' Inform.
MsgBox "Number of cumulations copied: " & ddrCount, vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/491497.html
上一篇：根據其他兩列的值選擇范圍