每次將資料粘貼到下一行時，我都需要運行此代碼。薪水表是原始資料檔案，最終薪水表是要復制資料的最終表。請幫忙
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim finalSh As Worksheet
Dim monthsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Salary Sheet")
Set finalSh = ThisWorkbook.Sheets("Final Salary")
Set monthsRange = DataSh.Range(DataSh.Cells(3, 1), DataSh.Cells(Rows.Count, 1).End(xlUp))
'I went from the cell row3/column1 (or a3) and go down until the last non empty cell
i = 2
For Each rCell In monthsRange 'loop through each cell in the range
If rCell = Sheets("Menu").Range("E6").Value Then 'check if the cell is equal to "range e6"
i = i 1 'Row number ( 1 everytime I found another "range e6")
finalSh.Cells(i, 1) = rCell.Offset(0, 0) 'month
finalSh.Cells(i, 2) = rCell.Offset(0, 1) 'emp id
finalSh.Cells(i, 3) = rCell.Offset(0, 2) 'emp name
finalSh.Cells(i, 4) = rCell.Offset(0, 3) 'designation
finalSh.Cells(i, 5) = rCell.Offset(0, 22) 'gross salary
End If
Next rCell
End Sub
uj5u.com熱心網友回復：
復制條件行
一個快速的解決辦法可能是，而不是
i = 2，使用：i = finalSh.Cells(finalSh.Rows.Count, 1).End(xlUp).Row這是一種更靈活的方法。
Option Explicit
Sub CopyCriteriaRows()
' Source
Const sName As String = "Salary Sheet"
Dim sCols As Variant: sCols = Array("A", "B", "C", "D", "W") ' read
Const slrCol As String = "A" ' Source Last Row Column
Const sCol As String = "A" ' Source (Criteria) Column
Const sfRow As String = 3
' Destination
Const dName As String = "Final Salary"
Dim dCols As Variant: dCols = Array("A", "B", "C", "D", "E") ' write
Const dlrCol As String = "A"
' Criteria
Const cName As String = "Menu"
Const cCellAddress As String = "E6"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data in column range
Dim slrg As Range ' Source Last Row Column Range
Set slrg = sws.Range(sws.Cells(sfRow, slrCol), sws.Cells(slRow, slrCol))
Dim srg As Range: Set srg = slrg.EntireRow.Columns(sCol)
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlrCol).End(xlUp).Row
Dim dCell As Range: Set dCell = dws.Cells(dlRow 1, dlrCol)
' Criteria
Dim cws As Worksheet: Set cws = wb.Worksheets(cName)
Dim cCell As Range: Set cCell = cws.Range(cCellAddress)
Dim Criteria As String: Criteria = CStr(cCell.Value)
' Other
Dim nLower As Long: nLower = LBound(sCols)
Dim nUpper As Long: nUpper = UBound(sCols)
Dim sCell As Range
Dim n As Long
' Read/Write.
For Each sCell In srg.Cells
If StrComp(CStr(sCell.Value), Criteria, vbTextCompare) = 0 Then
For n = nLower To nUpper
dCell.EntireRow.Columns(dCols(n)).Value _
= sCell.EntireRow.Columns(sCols(n)).Value
Next n
Set dCell = dCell.Offset(1)
End If
Next sCell
' Inform.
MsgBox "Month '" & Criteria & "' processed.", vbInformation
End Sub
uj5u.com熱心網友回復：
我認為你的錯誤是：
finalSh.Cells(i, 1).Value = rCell.Offset(0, 0).Value 'month
finalSh.Cells(i, 2).Value = rCell.Offset(0, 1).Value 'emp id
finalSh.Cells(i, 3).Value = rCell.Offset(0, 2).Value 'emp name
finalSh.Cells(i, 4).Value = rCell.Offset(0, 3).Value 'designation
finalSh.Cells(i, 5).Value = rCell.Offset(0, 22).Value 'gross salary
所以你的代碼可能是：
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim finalSh As Worksheet
Dim monthsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Salary Sheet")
Set finalSh = ThisWorkbook.Sheets("Final Salary")
Set monthsRange = DataSh.Range(DataSh.Cells(3, 1), DataSh.Cells(Rows.Count, 1).End(xlUp))
'I went from the cell row3/column1 (or a3) and go down until the last non empty cell
i = 2
For Each rCell In monthsRange 'loop through each cell in the range
If rCell = Sheets("Menu").Range("E6").Value Then 'check if the cell is equal to "range e6"
i = i 1 'Row number ( 1 everytime I found another "range e6")
finalSh.Cells(i, 1).Value = rCell.Offset(0, 0).Value 'month
finalSh.Cells(i, 2).Value = rCell.Offset(0, 1).Value 'emp id
finalSh.Cells(i, 3).Value = rCell.Offset(0, 2).Value 'emp name
finalSh.Cells(i, 4).Value = rCell.Offset(0, 3).Value 'designation
finalSh.Cells(i, 5).Value = rCell.Offset(0, 22).Value 'gross salary
End If
Next rCell
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/364556.html
上一篇：excel范圍過濾和計數行