필터링 된 데이터의 1 열을 다른 시트로 복사

Question

수동 처리를 대체하기 위해 쓰는 VBA 코드에 문제가 있습니다.

거의 끝까지 다되었지만 필자의 필터링 된 데이터를 열 기준으로 새 시트에 복사하는 데 어려움을 겪고 있습니다 (레이아웃이 새 시트에서 변경됨). 현재 가지고있는 코드는 셀 C2의 데이터 만 복사하는 것입니다.

아무에게도 이것을보고 내가 잘못 본 곳을 볼 수 있습니까? 아래 코드의 관련 부분을 복사했습니다.

미리 감사

'Copy formula down 

Range("F2:L2").Select 
Selection.Copy 
LR = Range("A" & Rows.Count).End(xlUp).Row 
Range("F2:L2").AutoFill Destination:=Range("F2:L" & LR), Type:=xlFillDefault 

Application.CutCopyMode = False 
Range("O1").goalseek Goal:=Range("Q1"), ChangingCell:=Range("U1") 

'Add Filter 
Range("A2").Select 
Selection.AutoFilter 
ActiveSheet.Range("$A$1:$L$5000").AutoFilter Field:=12, Criteria1:= _ 
    "1" 

'Move the data to the new sheet 

Sheets("Sheet1").Select 
LR = Range("A" & Rows.Count).End(xlUp).Row 
NextFree = Range("A2:A" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row 
Range("A" & NextFree).Select 
Range("A" & NextFree).SpecialCells(xlCellTypeVisible).Value2 = _ 
Worksheets("To Be Used").Range("C:C").SpecialCells(xlCellTypeVisible).Value2 

'This part is only copying the data from cell C2 when I need it to copy all of the filtered data  in column C aprt from C1 and there is a long delay 

Range("A" & NextFree).SpecialCells(xlCellTypeVisible).Value2 = _ 
Worksheets("To Be Used").Range("C2:C" & LR).SpecialCells(xlCellTypeVisible).Value2 

Answer 1

에 나는 smidge 코드를 강화했지만 나는 적절하게 .goalseek 기능을 테스트 할 수 없습니다 두려워. 필터링 된 열 C의 필터와 후속 복사/붙여 넣기가 예상대로 작동합니다.

Dim rw As Long, ws As Worksheet 
Set ws = Sheets("Sheet16") 'change the target worksheet name here 
With Sheets("To Be Used").Cells(1, 1).CurrentRegion 
    .Cells(2, 6).Resize(.Rows.Count - 1, 7).FillDown 
    .Range("O1").GoalSeek Goal:=.Range("Q1"), ChangingCell:=.Range("U1") 
    .AutoFilter 
    .AutoFilter Field:=12, Criteria1:="1" 
    If Application.Subtotal(103, .Columns(3)) > 1 Then 
     rw = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 
     .Columns(3).Offset(1, 0).Resize(.Rows.Count - 1, 1).Copy _ 
      Destination:=ws.Cells(rw, 1) 
     .Columns(1).Offset(1, 0).Resize(.Rows.Count - 1, 2).Copy _ 
      Destination:=ws.Cells(rw, 2) 
     .Columns(4).Offset(1, 0).Resize(.Rows.Count - 1, 2).Copy _ 
      Destination:=ws.Cells(rw, 4) 
    End If 
    .AutoFilter 
End With 
Set ws = Nothing