VBA에서 여러 행 복사/붙여 넣기

Question

간단한 복사 행을 시도하고 통합 문서 내에 행을 붙여 넣으려고합니다. 스레드를 검색하고 코드를 여러 번 변경해 보았습니다.

작업과 가장 가까운 것은이 작업이지만 일치하는 조건의 단일 인스턴스 만 복사합니다.

하나의 열에 일치하는 모든 행을 복사하는 루프를 만들려고합니다.

따라서 8 열이면 7 열의 값이 일치하는 각 행이 명명 된 시트에 복사해야합니다. 나는 다른 기준으로 여러 대상 시트를 대상으로 필요하지만 이상 복사 할 기준과 일치하는 모든 행을 필요로하기 때문에

Sub test() 
 
Set MR = Sheets("Main").Range("H1:H1000") 
 
Dim WOLastRow As Long, Iter As Long 
 

 
    For Each cell In MR 
 
    
 
If cell.Value = "X" Then 
 
cell.EntireRow.Copy 
 
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
If cell.Value = "Y" Then 
 
cell.EntireRow.Copy 
 
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
If cell.Value = "Z" Then 
 
cell.EntireRow.Copy 
 
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
If cell.Value = "AB" Then 
 
cell.EntireRow.Copy 
 
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial 
 
    End If 
 
    
 
Application.CutCopyMode = False 
 

 
Next 
 

 
End Sub

나는이를 좋아합니다.

이

아래 코드는 시트 Main에있는 모든 행을 복사 열 7

메모를 수행의 값에 따라 해당 워크 시트에 붙여 넣을 것입니다 : NEW 요청에 대한 응답으로

Answer 1

EDITED CODE : 기존 시트 이름과 일치하지 않는 7 열의 값이 있으면 코드에서 오류가 발생합니다. 해당 예외를 처리하도록 코드를 수정하십시오.

추가적인 도움이 필요하시면 알려주세요.

Sub CopyStuff() 
    Dim wsMain As Worksheet 
    Dim wsPaste As Worksheet 
    Dim rngCopy As Range 
    Dim nLastRow As Long 
    Dim nPasteRow As Long 
    Dim rngCell As Range 
    Dim ws As Worksheet 

    Const COLUMN_TO_LOOP As Integer = 7 

    Application.ScreenUpdating = False 

    Set wsMain = Worksheets("Main") 
    nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row 
    Set rngCopy = wsMain.Range("A2:H" & nLastRow) 

    For Each ws In ActiveWorkbook.Worksheets 
     If UCase(ws.Name) = "MAIN" Then 
      'Do Nothing for now 
     Else 
      Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents 
     End If 
    Next ws 

    For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP)) 
     On Error Resume Next 
     Set wsPaste = Worksheets(rngCell.Value) 
     On Error GoTo 0 

     If wsPaste Is Nothing Then 
      MsgBox ("Sheet name: " & rngCell.Value & " does not exist") 
     Else 

      nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1 

      wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1) 
     End If 

     Set wsPaste = Nothing 
    Next rngCell 

    Application.ScreenUpdating = True 
End Sub 

Answer 2

현재 코드는 대략 "열 A에서 스프레드 시트의 맨 아래로 이동, 열 A Range("A" & Rows.Count).End(xlUp) 말한다에 값이 마지막 행에, 반복해서 각각의 시트에서 같은 행에 붙여 넣기한다 , 그리고 그 곳에서 내용이있는 열 A의 다음으로 가장 낮은 셀로 점프하십시오. 그러면 매번 동일한 셀로 돌아올 것입니다.

대신, 패턴의 라인을 사용할 수 UsedRange 그들에 데이터 시트에있는 모든 셀을 포함하는 범위는

Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial 

. + 1을 누르면 다음 행을 볼 수 있습니다.

With Sheets("X")  
    .Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial  
End With