Makro ile süz ve aktar

[cuneyt_emir]

Merhabalar,

datanın bulunduğu sayfadaki verileri süzerek ilgili sayfaya aktarıyorum. Ancak verileri aktardığım sayfalarda sütun sıralamasının farklı yerde olmasını istiyorum. Örnek dosya ektedir.

(not:SÜZ VE YAPIŞTIR düğmesine basınca, spot yada seferlik girdiğiniz değere göre süzme ve aktarma yapıyor.)


İyi çalışmalar.

 

[asi_kral]

Merhaba
Her iki sayfadada veriler ayrı ayrı mı listelenecek_?

 

[cuneyt_emir]

evet ayrı ayrı listelenecek. ama sayfalardaki sütunların yerleri değişik.

 

[asi_kral]

evet ayrı ayrı listelenecek. ama sayfalardaki sütunların yerleri değişik.

İki sayfada farklı sutünlarda bilgiler doğru mu bu şekilde olacak değil mi_?

 

[cuneyt_emir]

evet. doğrudur

 

[asi_kral]

evet. doğrudur

Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub veri_süz_aktar_1967()
'Konu       :   İnput'a Göre Süz ve Aktar
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet, _
a As String, b As Long, c As Variant
Set kral = Sheets("HAFTALIK")
a = InputBox("Süz Bilgisini Giriniz", "Süz Bilgisi")
If a = Empty Then Exit Sub
Application.ScreenUpdating = False
Set asi = Sheets(a)
asi.Select
Range("A2:I" & Rows.Count).ClearContents
c = ActiveCell.Address
kral.Select
b = kral.Range("A" & Rows.Count).End(xlUp).Row
kral.Range("A1:I" & b).AutoFilter field:=8, Criteria1:=a
If WorksheetFunction.Subtotal(3, kral.Range("A2:A" & b)) > 0 Then
If WorksheetFunction.Proper(a) = "Sefer" Then
kral.Range("A2:A" & b).Copy: asi.Range("E2").PasteSpecial (xlPasteValues)
kral.Range("B2:B" & b).Copy: asi.Range("G2").PasteSpecial (xlPasteValues)
kral.Range("C2:C" & b).Copy: asi.Range("F2").PasteSpecial (xlPasteValues)
kral.Range("D2:D" & b).Copy: asi.Range("B2").PasteSpecial (xlPasteValues)
kral.Range("E2:E" & b).Copy: asi.Range("D2").PasteSpecial (xlPasteValues)
kral.Range("F2:F" & b).Copy: asi.Range("C2").PasteSpecial (xlPasteValues)
kral.Range("G2:G" & b).Copy: asi.Range("H2").PasteSpecial (xlPasteValues)
kral.Range("H2:H" & b).Copy: asi.Range("A2").PasteSpecial (xlPasteValues)
kral.Range("I2:I" & b).Copy: asi.Range("I2").PasteSpecial (xlPasteValues)
ElseIf WorksheetFunction.Proper(a) = "Spot" Then
kral.Range("A2:A" & b).Copy: asi.Range("A2").PasteSpecial (xlPasteValues)
kral.Range("B2:B" & b).Copy: asi.Range("B2").PasteSpecial (xlPasteValues)
kral.Range("C2:C" & b).Copy: asi.Range("C2").PasteSpecial (xlPasteValues)
kral.Range("D2:D" & b).Copy: asi.Range("D2").PasteSpecial (xlPasteValues)
kral.Range("E2:E" & b).Copy: asi.Range("E2").PasteSpecial (xlPasteValues)
kral.Range("F2:F" & b).Copy: asi.Range("F2").PasteSpecial (xlPasteValues)
kral.Range("G2:G" & b).Copy: asi.Range("G2").PasteSpecial (xlPasteValues)
kral.Range("H2:H" & b).Copy: asi.Range("H2").PasteSpecial (xlPasteValues)
kral.Range("I2:I" & b).Copy: asi.Range("I2").PasteSpecial (xlPasteValues)
End If: End If
kral.Range("A1:I" & b).AutoFilter
asi.Select
Range(c).Select
kral.Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub

Dosyanız Ekte.

 

[cuneyt_emir]

selamlar,
söylediğiniz kodu kullandım, yardımınız için teşekkür ederim.

ancak şöyle bir durum söz konusu, sayfa adı ile kriterin aynı olması zorunluluğu mevcut. bunu değiştirme gibi bir alternatif var mıdır? yani kriter ile sayfa adı farklı olacak.

kolay gelsin.

 

[asi_kral]

selamlar,
söylediğiniz kodu kullandım, yardımınız için teşekkür ederim.

ancak şöyle bir durum söz konusu, sayfa adı ile kriterin aynı olması zorunluluğu mevcut. bunu değiştirme gibi bir alternatif var mıdır? yani kriter ile sayfa adı farklı olacak.

kolay gelsin.

Evet yapılabilir bunu baştan söyleseydiniz ve dosyayı ona göre gönderseydiniz ayarlamayı yapardım.