한 시트에서 다른 시트로 불연속 범위 복사하기

Question

VBA 신참 (그리고 첫 번째 포스터)이 아마도 꽤 기본적인 질문 일 것입니다. 그러나, 나는 인터넷 (또는 내가 가지고있는 참조 서적) 어디서나 대답을 찾지 못했고, 그래서 나는 꽤 난처하게 굴었습니다.

간격을 띄우는 열을 한 시트에 넣고 다른 시트에 채우려면 어떻게해야합니까?

x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 

디자인 제약 :

같은 다른 시트에

x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 
x . . . x x . . x . . x 

:

예를 들어,이 같은 시트에서 X 년대로 표시된 셀을 복사 할

• 소스 범위의 연결이 끊어진 열입니다. 대상은 연속 블록입니다.
  • 예 : 원본 "A3 : B440, G3 : G440, I3 : I440"-> 대상 "A3 : D440"
• 값만. 대상에 보존해야하는 조건부 서식이 있습니다.
• 대상이 ListObject의 DataBodyRange 일부입니다.
• 원본 범위 열은 임의입니다. 그것들은 헤더 색인 기능에 의해 발견됩니다.
• 행 수는 임의이지만 원본과 대상 모두 동일합니다.
• 약 400 개의 행과 10-15 개의 열이 복사하려고합니다. 루프가 ... 귀찮아.

이 스 니펫은 작업을 완료하지만 너무 많은 것을 앞뒤로 수신하고 너무 오래 걸립니다. 나는 이것이 잘못된 길인 것처럼 느낍니다.

For Each hdrfield In ExportFields 

    RawDataCol = s_RawData.HeaderColumnPositions(hdrfield) 

    s_RawData.Activate 
    s_RawData.Range(s_RawData.Cells(3, RawDataCol), s_RawData.Cells(LastRow, RawDataCol)).Copy (s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i))) 
    s_Console.Activate 
    s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i)).Select 
    s_Console.Paste 

    i = i + 1 

Next hdrfield 

이 접근법도 유효합니다. 더 빠르고 더 안정적입니다. 그것은 내가 한 일이지만 소스 위치를 하드 코딩하면 더 이상 작동하지 않습니다.

'transfer just the important columns from the raw data sheet to the report line sheet 
s_Console.Range("A3:A" & upperlimit).Value = s_RawData.Range("A3:A" & upperlimit).Value 'timestamp 
s_Console.Range("B3:B" & upperlimit).Value = s_RawData.Range("I3:I" & upperlimit).Value 'H2.ppm 
s_Console.Range("C3:C" & upperlimit).Value = s_RawData.Range("J3:J" & upperlimit).Value 'H2_DG.ppm 
s_Console.Range("D3:D" & upperlimit).Value = s_RawData.Range("K3:K" & upperlimit).Value 'OilTemp or GasTemp 
s_Console.Range("E3:E" & upperlimit).Value = s_RawData.Range("L3:L" & upperlimit).Value 'H2_G.ppm 
s_Console.Range("F3:F" & upperlimit).Value = s_RawData.Range("q3:q" & upperlimit).Value 'H2_mt 
s_Console.Range("G3:G" & upperlimit).Value = s_RawData.Range("r3:r" & upperlimit).Value 'H2_oo 
s_Console.Range("H3:H" & upperlimit).Value = s_RawData.Range("s3:s" & upperlimit).Value 'H2_lg 
s_Console.Range("I3:I" & upperlimit).Value = s_RawData.Range("t3:t" & upperlimit).Value 'R1 
s_Console.Range("J3:J" & upperlimit).Value = s_RawData.Range("u3:u" & upperlimit).Value 'R2 
s_Console.Range("K3:K" & upperlimit).Value = s_RawData.Range("ab3:ab" & upperlimit).Value 't1 
s_Console.Range("L3:L" & upperlimit).Value = s_RawData.Range("ac3:ac" & upperlimit).Value 't2 
s_Console.Range("M3:M" & upperlimit).Value = s_RawData.Range("ah3:Ah" & upperlimit).Value 'Cycle Type 

두 가지를 혼용 할 수없는 이유는 무엇입니까? 이 코드가 작동하지 않는 이유는 무엇입니까?

s_console.range("A3:M" & lastrow).value = s_rawdata.exportrange 

은 (내가 이미 + 선택 내가 원하는 범위를 복사 할 수 있습니다 작성된 사용자 정의 "exportrange"속성을 가지고 ...하지만이 불연속이기 때문에 그것으로 다른 범위의 값을 설정할 수 없습니다)

도움 주셔서 감사합니다. 이것은 VBA 학습의 근본적인 부분 인 것 같아서 나는 단지 어떤 정보도 찾을 수 없다.

- 매트

당신은 Application.Union 기능을 활용할 수

Answer 1

중요한 점은 다음과 같이 한 번에 당신이 전체 불연속 범위를 복사 할 수 있다는 것입니다 알고 있어야 :

Sheet1.Range("A3:B440, G3:G440, I3:I440").Copy 
Sheet2.Range("A3").PasteSpecial xlValues 

주에 그 위의 Sheet1과 Sheet2는 codenames이지만, 아마도 ThisWorkbook.Worksheets("mySheet")과 같은 것을 사용할 것입니다.

내가 할 수있는 일이 무엇인지 확신 할 수 없어서 코드를 작성했습니다. 이 행 2에서 "복사"에 열을 검색, 찾기 및 FindNext를 사용하여 복사 할 열을 찾습니다

내 믿을 수없는 경악과 혼란으로

Sub CopyDiscontiguousColumns() 
Dim wsFrom As Excel.Worksheet 
Dim wsTo As Excel.Worksheet 
Dim RangeToCopy As Excel.Range 
Dim HeaderRange As Excel.Range 
Dim HeaderText As String 
Dim FirstFoundHeader As Excel.Range 
Dim NextFoundHeader As Excel.Range 
Dim LastRow As Long 

Set wsFrom = ThisWorkbook.Worksheets(1) 
Set wsTo = ThisWorkbook.Worksheets(2) 
'headers are in row 2 
Set HeaderRange = wsFrom.Rows(2) 
'This is the text that identifies columns to be copies 
HeaderText = "copy" 
With wsFrom 
    'look for the first instance of "copy" in the header row 
    Set FirstFoundHeader = HeaderRange.Find(HeaderText) 
    'if "copy" is found, we're off and running 
    If Not FirstFoundHeader Is Nothing Then 
     LastRow = .Cells(.Rows.Count, FirstFoundHeader.Column).End(xlUp).Row 
     Set NextFoundHeader = FirstFoundHeader 
     'start to build the range with columns to copy 
     Set RangeToCopy = .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column)) 
     'and then just keep doing the same thing in a loop until we get back to the start 
     Do 
     Set NextFoundHeader = HeaderRange.FindNext(NextFoundHeader) 
      If Not NextFoundHeader Is Nothing Then 
       Set RangeToCopy = Union(RangeToCopy, .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column))) 
      End If 
     Loop While Not NextFoundHeader Is Nothing And NextFoundHeader.Address <> FirstFoundHeader.Address 
    End If 
End With 
RangeToCopy.Copy 
Sheet2.Range("A3").PasteSpecial xlValues 
End Sub 

Answer 2

:이 모든 선택하지 않고 (잘 작동한다 (나는 그것을 테스트하지 않은)

Sub macro1() 

Dim rngUnion As Range 

With Application 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
End With 

With s_RawData 
    Set rngUnion = Application.Union(.Range("A3:B" & upperlimit), .Range("G3:G" & upperlimit), .Range("I3:I" & upperlimit)) 
    rngUnion.Copy Destination:=s_Console.Range("A1") 
End With 

With Application 
    .ScreenUpdating = True 
    .Calculation = xlCalculationAutomatic 
End With 


End Sub 

이 또한 내가 생각하고 주위에 수신 거부 ...와) 원래 루프보다 훨씬 더 빠르게 처리 될 수 :

With Application 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
End With 

For Each hdrfield In ExportFields 

    RawDataCol = s_RawData.HeaderColumnPositions(hdrfield) 

    s_RawData.Range(s_RawData.Cells(3, RawDataCol), s_RawData.Cells(LastRow, RawDataCol)).Copy Destination:=s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i)) 

    i = i + 1 

Next hdrfield 

With Application 
    .ScreenUpdating = True 
    .Calculation = xlCalculationAutomatic 
End With