Опитвам се да копирам диапазон от редове, където избраните редове са базирани на стойността в една клетка. Искам да направя това за всички редове, съдържащи една и съща стойност в клетка, след което да премина към следващата стойност и да добавя към отдолу на първия списък.
По-долу е моят опит да обясня какво искам да постигна - надявам се, че горното ще помогне да обясня повече моята дилема. Огледах се за това, но не намерих точно това, което искам. Мислех, че ще е просто и вероятно е така.
Получавам дъмп на данни с хиляди редове с данни и 18 колони. Въз основа на стойността на колона P „Договор“ искам да копирам цели редове в нов единичен работен лист workingdata
. Не всички данни ще влязат в работния лист workingdata
.
Номерата на договорите са c1234, c1235, c2345 и т.н.
Това, което постигнах, е копиране и сортиране, така че копирайте всички редове с данни, където номерът на договора е c1234, в workingdata
, след това директно под него копирайте всички редове, където договорът е c1235 и т.н.
Мислех, че мога да избера диапазона P:P и да сортирам, но без резултат.
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
workingdata
?? - person Jonas Heidelberg   schedule 13.04.2011