• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Koşula göre satır kopyalama

  • Konbuyu başlatan Konbuyu başlatan steppe
  • Başlangıç tarihi Başlangıç tarihi
S

steppe

Katılım
7 Ağustos 2011
Mesajlar
319
Excel Vers. ve Dili
2003-2010 Türkçe
Yüzlerce adaylara ait bilgileri koşula uyanları sayfa1'den sayfa2'ye kopyalamak istiyorum.Örnek dosya ektedir.Yardımlarınız için şimdiden teşekkürler.
 

Ekli dosyalar

Dosyanız ektedir.:cool:
Kod: 
Private Sub CommandButton1_Click()
Dim sat1 As Long, i As Long, sh As Worksheet, sat2 As Long
Dim j As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Application.ScreenUpdating = False
sh.Range("A2:F" & Rows.Count).Clear
sat1 = Cells(Rows.Count, "C").End(xlUp).Row
sat2 = 2
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        For j = 2 To sat1
            If Cells(j, "C").Value = ListBox1.list(i, 0) Then
                Range("A" & j & ":F" & j).Copy sh.Range("A" & sat2)
                sat2 = sat2 + 1
            End If
        Next j
    End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"
End Sub

Private Sub UserForm_Click()

End Sub
Option Base 1
Private Sub UserForm_Initialize()
Dim sat As Long, z As Object, list(), i As Long
Sheets("Sayfa1").Select
Set z = CreateObject("Scripting.dictionary")
sat = Cells(Rows.Count, "C").End(xlUp).Row
list = Range("C2:C" & sat).Value
For i = 1 To UBound(list)
    If Not z.exists(list(i, 1)) Then z.Add (list(i, 1)), Nothing
Next
ListBox1.list = Application.Transpose(Array(z.keys))

End Sub
 

Ekli dosyalar

Orion1 Hocam,
Yardımlarınız için çok teşekkür ederim.Tam istediğim gibi olmuş.Yalnız bir şey daha sorabilir miyim?Koşul sabit olursa ,yani sürekli İstanbul,Ankara Antalya doğumlu olanları kopyalamak istersek nasıl olur?
 
steppe' Alıntı:
Orion1 Hocam,
Yardımlarınız için çok teşekkür ederim.Tam istediğim gibi olmuş.Yalnız bir şey daha sorabilir miyim?Koşul sabit olursa ,yani sürekli İstanbul,Ankara Antalya doğumlu olanları kopyalamak istersek nasıl olur?
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Private Sub UserForm_Initialize()
Dim sat As Long, z As Object, list(), i As Long
Me.Caption = Format(Date, "dd.mmmm.yyyy  dddd") & " evrengizlen@hotmail.com"
Sheets("Sayfa1").Select
Set z = CreateObject("Scripting.dictionary")
sat = Cells(Rows.Count, "C").End(xlUp).Row
list = Range("C2:C" & sat).Value
For i = 1 To UBound(list)
    If Not z.exists(list(i, 1)) Then z.Add (list(i, 1)), Nothing
Next
ListBox1.list = Application.Transpose(Array(z.keys))
Set z = Nothing: Erase list
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.list(i, 0) = "İstanbul" Or ListBox1.list(i, 0) = "Ankara" _
        Or ListBox1.list(i, 0) = "Antalya" Then ListBox1.Selected(i) = True
Next i
End Sub
 

Ekli dosyalar

UserFom-ListBox kullanmadan makro kodunun içine İstanbul,Ankara,Antalya yazarak satırı nasıl kopyalayabilirim.
 
steppe' Alıntı:
UserFom-ListBox kullanmadan makro kodunun içine İstanbul,Ankara,Antalya yazarak satırı nasıl kopyalayabilirim.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Sub aktar_59()
Dim sat1 As Long, sh As Worksheet, sat2 As Long
Dim j As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Application.ScreenUpdating = False
sh.Range("A2:F" & Rows.Count).Clear
sat1 = Cells(Rows.Count, "C").End(xlUp).Row
sat2 = 2
For j = 2 To sat1
    If Cells(j, "C").Value = "İstanbul" Or Cells(j, "C").Value = "Ankara" _
    Or Cells(j, "C").Value = "Antalya" Then
            Range("A" & j & ":F" & j).Copy sh.Range("A" & sat2)
            sat2 = sat2 + 1
    End If
Next j
Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Evren bey Merhaba.

170.000 satır veriden oluşan bir tablom var.

isim satırında yinelenen değerlerin karşısındaki fiyatlardan anlamsız olanları bulmaya çalışıyoruz.

yani A satırında yinelenen değerlerin karşılığına gelen fiyatların koşullu biçimlendirmeyle kıyaslanması en düşük ve en yüksek değerlerin renklenmesi. veya var olan değerlerden örnek AYNI İSİMLİ 13 ÜRÜNÜN 10 adeti 2000 TL olsun 2 taneside 5000 1 taneside 250 tl olsun işte bu anlamsız değerleri belirlemeye çalışıyoruz. YANİ BU ÜRÜNÜN GERÇEK DEĞERİ 2000TL ANLAMSIZLAR 5000 VE 250 TL GİBİ.

Nasıl yapabiliriz. Acil yardım edermisiniz.
 
Orion1' Alıntı:
Dosyanız ektedir.:cool:
Kod: 
Sub aktar_59()
Dim sat1 As Long, sh As Worksheet, sat2 As Long
Dim j As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Application.ScreenUpdating = False
sh.Range("A2:F" & Rows.Count).Clear
sat1 = Cells(Rows.Count, "C").End(xlUp).Row
sat2 = 2
For j = 2 To sat1
    If Cells(j, "C").Value = "İstanbul" Or Cells(j, "C").Value = "Ankara" _
    Or Cells(j, "C").Value = "Antalya" Then
            Range("A" & j & ":F" & j).Copy sh.Range("A" & sat2)
            sat2 = sat2 + 1
    End If
Next j
Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"
End Sub
Genişletmek için tıkla ...
Evren Hocam,
Yardımların için çok teşekkür ederim.Bir eklenti yapabilir miyiz?Sayfa2'ye kopyalamada her seferinde yeni veriyi üzerine kopyalıyor.Acaba Öncekini silmeden alttaki satıra kopyalayarak nasıl devam edebilir.
 
steppe' Alıntı:
Evren Hocam,
Yardımların için çok teşekkür ederim.Bir eklenti yapabilir miyiz?Sayfa2'ye kopyalamada her seferinde yeni veriyi üzerine kopyalıyor.Acaba Öncekini silmeden alttaki satıra kopyalayarak nasıl devam edebilir.
Genişletmek için tıkla ...
Alttaki kırmızı yerler ile eski yazılanları değiştiriniz.:cool:
Kod:
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
For j = 2 To sat1
If Cells(j, "C").Value = "İstanbul" Or Cells(j, "C").Value = "Ankara" _
Or Cells(j, "C").Value = "Antalya" Then
Range("A" & j & ":F" & j).Copy sh.Range("A" & sat2)
sat2 = sat2 + 1
End If
Next j
 
Orion1' Alıntı:
Alttaki kırmızı yerler ile eski yazılanları değiştiriniz.:cool:
Kod:
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
For j = 2 To sat1
If Cells(j, "C").Value = "İstanbul" Or Cells(j, "C").Value = "Ankara" _
Or Cells(j, "C").Value = "Antalya" Then
Range("A" & j & ":F" & j).Copy sh.Range("A" & sat2)
sat2 = sat2 + 1
End If
Next j
Genişletmek için tıkla ...

Evren Hocam,
Kırmızı yeri değiştirdim,fakat bir değişiklik olmadı.Yine yeni kaydı üzerine yapıyor.
 
aşağıdaki düzeltemeyide ekledim.Onu unutmuşum.

Application.ScreenUpdating = False
sh.Range("A2:F" & Rows.Count).Clear
sat1 = Cells(Rows.Count, "C").End(xlUp).Row
 
Evren Hocam,
Değişiklikleri yapmama rağmen kodu çalıştıramadım.Size zahmet olmazsa tüm kodu değişiklikleri ile yazabilir misiniz?
 
steppe' Alıntı:
Evren Hocam,
Değişiklikleri yapmama rağmen kodu çalıştıramadım.Size zahmet olmazsa tüm kodu değişiklikleri ile yazabilir misiniz?
Genişletmek için tıkla ...
Buyurun.:cool:

Kod: 
Sub aktar_59()
Dim sat1 As Long, sh As Worksheet, sat2 As Long
Dim j As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Application.ScreenUpdating = False
'sh.Range("A2:F" & Rows.Count).Clear
sat1 = Cells(Rows.Count, "C").End(xlUp).Row
sat2 = sh.Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To sat1
    If Cells(j, "C").Value = "İstanbul" Or Cells(j, "C").Value = "Ankara" _
    Or Cells(j, "C").Value = "Antalya" Then
            Range("A" & j & ":F" & j).Copy sh.Range("A" & sat2)
            sat2 = sat2 + 1
    End If
Next j
Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"
End Sub
 
Evren Hocam,
Yardımlarınız için çok teşekkür ederim.
 
Hocam merhabalar benimde buna benzer bir sorunum var bende bir satırdaki rota sakarya olduğuna ve bu sipariş 7353 kilodan büyük ise ikinci sayfaya kesilip yapıştırılmasını istiyorum fakat beceremedeim yardımcı olurmusunuz. Dosya ekliyorum.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst