Bir dizi hücre kopyalayın ve yalnızca veri içeren hücreleri seçin

Question

Bir hücre aralığını kopyalamak için bir yol arıyorum, ancak yalnızca bir değer içeren hücreleri kopyalamak için.

Veri sayfamda A1-A18'den veri var, B boş ve C1-C2. Şimdi bir değer içeren tüm hücreleri kopyalamak istiyorum.

With Range("A1") 
    Range(.Cells(1, 1), .End(xlDown).Cells(50, 3)).Copy 
End With 

Bu A1-C50 kadar her şeyi kopyalar, ama ben sadece bu verileri içerir sanki A1-A18 ve C1-C2 görülen çoğaltılamaz istiyorum. Ancak, B'de veya veri aralığım uzandığında, bunların da kopyalanacağı bir şekilde oluşturulması gerekiyor.

'So the range could be 5000 and it only selects the data with a value. 
With Range("A1") 
Range(.Cells(1, 1), .End(xlDown).Cells(5000, 3)).Copy 
End With 

Teşekkürler! Jean, Güncel koduna

---

Teşekkür:

Sub test() 

Dim i As Integer 
Sheets("Sheet1").Select 
i = 1 

With Range("A1") 
    If .Cells(1, 1).Value = "" Then 
    Else 
    Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("A" & i) 
    x = x + 1 
    End If 
End With 

Sheets("Sheet1").Select 

x = 1 
With Range("B1") 
' Column B may be empty. If so, xlDown will return cell C65536 
' and whole empty column will be copied... prevent this. 
    If .Cells(1, 1).Value = "" Then 
     'Nothing in this column. 
     'Do nothing. 
    Else 
     Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("B" & i) 
     x = x + 1 
    End If 
End With 

Sheets("Sheet1").Select 

x = 1 
With Range("C1") 
    If .Cells(1, 1).Value = "" Then 
    Else 
     Range(.Cells(1, 1), .End(xlDown)).Copy Destination:=Sheets("Sheet2").Range("C" & i) 
     x = x + 1 
    End If 
End With 

End Sub 

A1 - A5 verileri içeren, A6 blanc olduğunu A7 verileri içerir. A6'da durur ve B sütununa doğru ilerler ve aynı şekilde devam eder.

Answer 1

Üç sütununuz farklı boyutlara sahip olduğundan, yapılacak en güvenli şey tek tek kopyalamaktır. PasteSpecial'taki tüm kısayollar muhtemelen size baş ağrısına neden olacaktır.

With Range("A1") 
    Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeA 
End With 

With Range("B1") 
    ' Column B may be empty. If so, xlDown will return cell C65536 
    ' and whole empty column will be copied... prevent this. 
    If .Cells(1, 1).Value = "" Then 
     'Nothing in this column. 
     'Do nothing. 
    Else 
     Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeB 
    EndIf 
End With 

With Range("C1") 
    Range(.Cells(1, 1), .End(xlDown)).Copy myDestinationRangeC 
End With 

Şimdi bu çirkin ve daha temiz bir seçenek sayıda sütun varsa ve aynı sırada bitişik sütunlara onları yapıştırırken, özellikle sütunlar döngü olacaktır.

Sub CopyStuff() 

    Dim iCol As Long 

    ' Loop through columns 
    For iCol = 1 To 3 ' or however many columns you have 
     With Worksheets("Sheet1").Columns(iCol) 
      ' Check that column is not empty. 
      If .Cells(1, 1).Value = "" Then 
       'Nothing in this column. 
       'Do nothing. 
      Else 
       ' Copy the column to the destination 
       Range(.Cells(1, 1), .End(xlDown)).Copy _ 
        Destination:=Worksheets("Sheet2").Columns(iCol).Cells(1, 1) 
      End If 
     End With 
    Next iCol 

End Sub 

---

DÜZENLEME Yani şimdiki hücre boşsa kontrol bireysel hücrelerin döngü deneyin ... Sorunuzu değiştirdi ve kopyalamak değilse ettik. Bu test, ama fikir olsun mı: Bu kod iMaxRow büyükse gerçekten yavaş olacak

iMaxRow = 5000 ' or whatever the max is. 
    'Don't make too large because this will slow down your code. 

    ' Loop through columns and rows 
    For iCol = 1 To 3 ' or however many columns you have 
     For iRow = 1 To iMaxRow 

     With Worksheets("Sheet1").Cells(iRow,iCol) 
      ' Check that cell is not empty. 
      If .Value = "" Then 
       'Nothing in this cell. 
       'Do nothing. 
      Else 
       ' Copy the cell to the destination 
       .Copy Destination:=Worksheets("Sheet2").cells(iRow,iCol) 
      End If 
     End With 

     Next iRow 
    Next iCol 

. Önsezim, bir problemi bir tür verimsiz şekilde çözmeye çalıştığınızdır ... Soru değişmeye devam ettiği zaman optimal bir stratejiye yerleşmek biraz zor.

Answer 2

Pas özel işlevine bakın. Size yardımcı olabilecek bir 'boş' atlama özelliği var.

Answer 3

Jean-Francois Corbett'ın yanıtını geliştirmek için, son kullanılan satırı almak için .UsedRange.Rows.Count kullanın. Bu size oldukça doğru bir aralık verecektir ve ilk boş hücrede durmayacaktır.

İşte ... başlayanlar için yorumladı notlar ile mükemmel bir örnek bir bağlantıdır

• Excel macro - paste only non empty cells from one sheet to another - Stack Overflow