koşullu aktarım makrosunda düzenleme

[airborne]

s.a.

Sub Düğme1_Tıklat()
Sheets("Sayfa3").Select
Range("A1").Select
Set s1 = Sheets("sayfa1")
Set s4 = Sheets("sayfa3")
son_s1 = s1.[a65536].End(3).Row
SATIR = 3
say = 4
For x = 3 To son_s1
If s1.Cells(x, "F") = 2 Then
say = say + 1
SATIR = SATIR + 1
If SATIR = 53 Then SATIR = 54
If SATIR > 54 Then Exit Sub
s4.Cells(SATIR, "B") = say
s4.Cells(SATIR, "B") = s1.Cells(x, "B")
s4.Cells(SATIR, "C") = s1.Cells(x, "C")
End If
Next
End Sub

ile aktarım yapabiliyorum. Problemim ise sayfa1'de bulunan K sütununda aynı şartları taşıyan H ve I sütunlarındaki verileri bu makro içerisinde nasıl aktarabilirim. Sayfa3 te bulunan B ve C sütunlarına hepside aktarılacak.

 

[İhsan Tank]

bu şekilde yardım almanız ve soruyu anlamamız biraz zor görünüyor. Lütfen örnek dosya ekleyiniz

 

[airborne]

s.a.

Hocam dosya ektedir.

İlginiz için Allah Razı olsun....

Selametle....

 

[İhsan Tank]

s.a.

Hocam dosya ektedir.

İlginiz için Allah Razı olsun....

Selametle....

:agla: ama hiç açıklama yok neye göre nereye aktarılacak

 

[airborne]

s.a.

hocam Sayfa 1 de bulunan K ve F sunlarında 2 olanların hepsinin Adı Soyadı ve Branşları Sayfa 3 teki tabloya aktarılacak.

 

[İhsan Tank]

s.a.

hocam Sayfa 1 de bulunan K ve F sunlarında 2 olanların hepsinin Adı Soyadı ve Branşları Sayfa 3 teki tabloya aktarılacak.

Aleyküm Selam
Peki bu 52 veriyi geçmeyecek mi_? Hiç bir şekilde

 

[airborne]

s.a.

evet hocam

 

[İhsan Tank]

s.a.

evet hocam

Aleyküm Selam
Boş bir module kopyalayın ve deneyin

Option Explicit
Sub aktarım()
Dim ts, kaplan, trabzonspor
trabzonspor = MsgBox("2 Olanları Aktarıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
Sheets("Sayfa3").Range("A4:D52").ClearContents
kaplan = 4
For ts = 4 To Sheets("Sayfa1").Cells(45, "B").End(xlUp).Row
If Sheets("Sayfa1").Cells(ts, "F") = 2 Then
Sheets("Sayfa3").Cells(kaplan, "B") = Sheets("Sayfa1").Cells(ts, "B")
Sheets("Sayfa3").Cells(kaplan, "C") = Sheets("Sayfa1").Cells(ts, "C")
Sheets("Sayfa3").Cells(kaplan, "D") = Sheets("Sayfa1").Cells(ts, "D")
kaplan = kaplan + 1
End If
Next
For ts = 4 To Sheets("Sayfa1").Cells(45, "H").End(xlUp).Row
If Sheets("Sayfa1").Cells(ts, "K") = 2 Then
Sheets("Sayfa3").Cells(kaplan, "B") = Sheets("Sayfa1").Cells(ts, "H")
Sheets("Sayfa3").Cells(kaplan, "C") = Sheets("Sayfa1").Cells(ts, "I")
Sheets("Sayfa3").Cells(kaplan, "D") = Sheets("Sayfa1").Cells(ts, "J")
kaplan = kaplan + 1
End If
Next
Sheets("Sayfa3").Range("A4") = 1
Sheets("Sayfa3").Range("A4:A" & kaplan - 1).DataSeries rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, step:=1, Trend:=True
Application.ScreenUpdating = True
MsgBox "2 Olanları Aktardım", vbInformation, "Bitiş"
End Sub

 

[airborne]

s.a.

hocam teşekkür ederim.

İnşaallah istediğiniz yerlere gidersiniz. ve bizim içinde dua edersiniz gidebilmemiz için.

Selametle......................

 

[İhsan Tank]

s.a.

hocam teşekkür ederim.

İnşaallah istediğiniz yerlere gidersiniz. ve bizim içinde dua edersiniz gidebilmemiz için.

Selametle......................

Aleyküm Selam
İnşallah Dualar Tüm Ümmedi Muhammed İçin
kolay gelsin
:yazici: