Excel 2007，基于1列中的值将行从一张纸复制到另一张纸
|
我正在尝试复制一系列行，其中选择的行基于一个单元格中的值。我想对一个单元格中包含相同值的所有行执行此操作，然后继续执行下一个附加值第一个列表的底部。
以下是我尝试解释我希望达到的目标的尝试-希望以上内容可以帮助解释我的更多难题。我已经四处寻找，但还没有找到我想要的。我认为这很简单，也许是。
我收到包含数千行数据和18列的数据转储。基于列P \“ Contract \”的值，我要将整个行复制到新的单个工作表
workingdata
workingdata
Sheets(\"Data Dump\").Select
Columns(\"P:P\").Select
If Selection.Value = \"C1234\" Then
Selection.EntireRow.copy
Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range
Set oWorksheet = Worksheets(\"DataDump\")
Set oRangeSource = oWorksheet.Range(\"p:p\")
Set oRangeDest = Worksheets(\"workingdata\")
If oRangeSource=\"CA0004000\" Then Select.EntireRow
Selection.EntireRow.copy
Sheets(\"workingdata\").Select.Paste
End If
Sub copy()
\'
\' copy Macro
\'
Dim rngContracts As Range: Set rngContracts = Sheets(\"DataDump\").Range(\"P:P\")
Dim wsData As Worksheet
Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = \"Working Data\" Then
Set wsData = ws
wsFound = True
Exit For
End If
Next ws
If wsFound = False Then
Application.CutCopyMode = False
ActiveSheet.Range(\"A1\").EntireRow.copy
Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
wsData.Name = \"Working Data\"
wsData.Range(\"A1\").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Dim iCell As Range
For Each iCell In rngContracts
If iCell.EntireRow.Hidden = False Then
Application.CutCopyMode = False
iCell.EntireRow.copy
wsData.Range(\"P\" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Next iCell
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub copytest()
\'
\' copytest Macro
\'
Set MR = Sheets(\"data Dump\").Range(\"P:P\")
For Each cell In MR
If cell.Value = \"CA000154\" Then
cell.EntireRow.copy
Sheets(\"working data\").Range(\"A\" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = \"CA000220\" Then
cell.EntireRow.copy
Sheets(\"working data\").Range(\"A\" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = \"CA000393\" Then
cell.EntireRow.copy
Sheets(\"working data\").Range(\"A\" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = \"CA000429\" Then
cell.EntireRow.copy
Sheets(\"working data\").Range(\"A\" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
没有找到相关结果
已邀请:
1 个回复
僻朵庙惩竣