Sayfadaki Kritere Göre Değerleri Ayırma

  • Konuyu başlatan Konuyu başlatan gicimi
  • Başlangıç tarihi Başlangıç tarihi
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

gicimi

Katılım
26 Haz 2018
Mesajlar
173
Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
Merhaba;

Ekteki dosyada Sayfa1 de yer alan "C" Sütunundaki satırların değerleri "1" olanları Sayfa2 "0" olanları Sayfa3, Boş ve metin içeren değerleri ise Boş Sayfasına A ve B Sütunlarındaki bilgiler ile birlikte aktarmak istiyorum. Konu hakkında yardımcı olabilir misiniz.

Satır sayısı : 15.000 ile 55.000 adettir.
 
Formüllü Hücreyi Formülsüz Hale Getirme
Alt Alta Sıralananları Yan Yana Getirme

Ekli dosyalar

Çözüm
Kod böyle alacak.

VBA: 
Sub aktar()

Dim arr, arr1, arr2, arr3, i As Long, say As Long, say1 As Long, say2 As Long

Sayfa2.Range("A2:C" & Rows.Count).ClearContents
Sayfa3.Range("A2:C" & Rows.Count).ClearContents
Sayfa4.Range("A2:C" & Rows.Count).ClearContents

arr = Sayfa1.Range("A2:C" & Sayfa1.Cells(Rows.Count, 1).End(3).Row).Value

ReDim arr1(1 To UBound(arr), 1 To 3)
ReDim arr2(1 To UBound(arr), 1 To 3)
ReDim arr3(1 To UBound(arr), 1 To 3)

Application.ScreenUpdating = False
For i = LBound(arr) To UBound(arr)

If arr(i, 3) = "0" And Len(arr(i, 3)) > 0 Then
         say = say + 1
    arr1(say, 1) = arr(i, 1)
    arr1(say, 2) = arr(i, 2)
    arr1(say, 3) = arr(i, 3)
ElseIf arr(i, 3) = 1 Or arr(i, 3) = "1" Then
         say1 = say1 + 1...
Tarihe göre sırala Oylamaya göre sırala
VBA: 
Sub aktar()

Dim arr, arr1, arr2, arr3, i As Long, say As Long, say1 As Long, say2 As Long

Sayfa2.Range("A2:C" & Rows.Count).ClearContents
Sayfa3.Range("A2:C" & Rows.Count).ClearContents
Sayfa4.Range("A2:C" & Rows.Count).ClearContents

arr = Sayfa1.Range("A2:C" & Sayfa1.Cells(Rows.Count, 1).End(3).Row).Value

ReDim arr1(1 To UBound(arr), 1 To 3)
ReDim arr2(1 To UBound(arr), 1 To 3)
ReDim arr3(1 To UBound(arr), 1 To 3)

Application.ScreenUpdating = False
For i = LBound(arr) To UBound(arr)

If arr(i, 3) = 0 And Len(arr(i, 3)) > 0 Then
    say = say + 1
    arr1(say, 1) = arr(i, 1)
    arr1(say, 2) = arr(i, 2)
    arr1(say, 3) = arr(i, 3)
ElseIf arr(i, 3) = 1 Then
    say1 = say1 + 1
    arr2(say1, 1) = arr(i, 1)
    arr2(say1, 2) = arr(i, 2)
    arr2(say1, 3) = arr(i, 3)
    
 Else
    say2 = say2 + 1
    arr3(say2, 1) = arr(i, 1)
    arr3(say2, 2) = arr(i, 2)
    arr3(say2, 3) = arr(i, 3)
End If


Next
Application.ScreenUpdating = True

Sayfa2.Range("A2").Resize(say, 3).Value = arr2
Sayfa3.Range("A2").Resize(say1, 3).Value = arr1
Sayfa4.Range("A2").Resize(say2, 3).Value = arr3

Erase arr: Erase arr1: Erase arr2: Erase arr3

End Sub

Deneyin
 
Oyla 0 Olumsuz oyla
Kod böyle alacak.

VBA: 
Sub aktar()

Dim arr, arr1, arr2, arr3, i As Long, say As Long, say1 As Long, say2 As Long

Sayfa2.Range("A2:C" & Rows.Count).ClearContents
Sayfa3.Range("A2:C" & Rows.Count).ClearContents
Sayfa4.Range("A2:C" & Rows.Count).ClearContents

arr = Sayfa1.Range("A2:C" & Sayfa1.Cells(Rows.Count, 1).End(3).Row).Value

ReDim arr1(1 To UBound(arr), 1 To 3)
ReDim arr2(1 To UBound(arr), 1 To 3)
ReDim arr3(1 To UBound(arr), 1 To 3)

Application.ScreenUpdating = False
For i = LBound(arr) To UBound(arr)

If arr(i, 3) = "0" And Len(arr(i, 3)) > 0 Then
         say = say + 1
    arr1(say, 1) = arr(i, 1)
    arr1(say, 2) = arr(i, 2)
    arr1(say, 3) = arr(i, 3)
ElseIf arr(i, 3) = 1 Or arr(i, 3) = "1" Then
         say1 = say1 + 1
    arr2(say1, 1) = arr(i, 1)
    arr2(say1, 2) = arr(i, 2)
    arr2(say1, 3) = arr(i, 3)
    
 Else
         say2 = say2 + 1
    arr3(say2, 1) = arr(i, 1)
    arr3(say2, 2) = arr(i, 2)
    arr3(say2, 3) = arr(i, 3)
End If


Next
Application.ScreenUpdating = True

Sayfa2.Range("A2").Resize(say1, 3).Value = arr2
Sayfa3.Range("A2").Resize(say, 3).Value = arr1
Sayfa4.Range("A2").Resize(say2, 3).Value = arr3

Erase arr: Erase arr1: Erase arr2: Erase arr3

End Sub
 
Oyla 1 Olumsuz oyla
Çözüm
Merhabalar.
Sayın @gicimi, destek verenlere teşekkür iletmeniz güzel ancak.
Verilen cevap seçeneklerine ilişkin kısa da olsa bir değerlendirme (doğruluk, hız gibi) yapmanız daha doğru olmaz mı?

Yazdığınız son cevaptan, sorunun çözülüp çözülmediği dahi net olarak anlaşılmıyor.
.
 
Oyla 0 Olumsuz oyla
Ömer Hocam haklısınız. Henüz kendi dosyam üzerinde deneme şansım olmadı malesef önerinizi dikkate alıyorum bir sonraki konularda dikkat edeceğim. Uyarınız için teşekkür ederim.
 
Oyla 0 Olumsuz oyla
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Benzer Konular Popüler İçerikler Daha Fazlası
Geri
Üst Alt