Bir sheetteki bazı dataları başka bir sheete istenilen sırayla aktarmak

[sakoz]

Sevgili Excel Üstadları Merhaba ,

Tekrar bir konuda yardımınıza ihtiyac duyuyorum...Ekte gönderdigim dosya hergün hazırlanan bir dosyadır.
Bu dosyada pivot ve data sheetleri bulunmakta.Benim yapmak istedigim data sheetiyle ilgili...

Buradaki peron nosuna bakarak C,D ve E sütunlarındaki bilgileri başka bir sheete yazacak ve yazma sırası E,C,D şeklinde olacak.....
Görmeniz açısından , gönderdigim dosyada birde sonuc sheeti ekledim.Normalde bu sheet olmuyor.
Yalnız ayrı bir durum var...Data shetinde peron nolarının sonunda bazen farklı bilgilerde bulunuyor (Gönderdigim dosya bu şekilde) Bu bilgileri almak istemiyoruz.Sadece peron nosu olan satırları almak istiyoruz.
Bunu yapabilecek bir makro yapabilirmiyiz acaba ?

İlgilenen üstadların hepsine şimdiden teşekkür ederim...

 

[hsayar]

bu sonda bulunan veriler metin fortmatında mı daima
peron 16 dan sonra
ne bileyim rakamla başalayan yer almaması gereken satır olabilirmi?

 

[hsayar]

Sub peron()
Dim sfDTA, sfSNC As Worksheet
Set sfDTA = Sheets("DATA")
Set sfSNC = Sheets("SONUC")
sonsat = sfDTA.[a65536].End(3).Row
snc = 1
For knt = 1 To sonsat
deger = sfDTA.Cells(knt, 1)
    If IsNumeric(deger) = True And deger <> "" Then
        snc = snc + 1
        sfSNC.Cells(snc, 1) = sfDTA.Cells(knt, 5)
        sfSNC.Cells(snc, 2) = sfDTA.Cells(knt, 4)
        sfSNC.Cells(snc, 3) = sfDTA.Cells(knt, 3)
        'sfSNC.Cells(snc, 4) = sfDTA.Cells(knt, 1) 'peron nosuda yazs&#305;n isterseniz ba&#351;taki kesme i&#351;aretini kald&#305;r&#305;n&#305;z .
    End If
Next knt
End Sub

 

[sakoz]

Çok Sevgili H.Sayar Üstadım ,

Yine imdadımıza hızır gibi yetiştiniz...Yaptığınız makro tam anlamıyla istedigimizi yapıyor...
Tekrar tekrar teşekkürler...İyi çalışmalar...

 

[hsayar]

rica ederim

 

[sakoz]

Affınıza sıgınarak birsey daha sormak istiyorum...SONUC shetini makroyla otomatik açtırabilirmiyiz...Tekrar Teşekkürler...

 

[hsayar]

tabi olurda yeni kitaptamı saklanacak yoksa aynı çalışma kitabınamıo sayfa açılacak?

 

[sakoz]

Aynı çalışma kitabında sayfa açılması yeterli olacaktır HSAYAR üstadım ...

 

[hsayar]

buyrun

Sub peron2()
Dim sfDTA, sfSNC As Worksheet
Set sfDTA = Sheets("DATA")
Set sfSNC = Sheets.Add: sfSNC.Name = "SONUC"
sfSNC.Move After:=Sheets(Sheets.Count)
sonsat = sfDTA.[a65536].End(3).Row
snc = 1
sfSNC.Cells(snc, 1) = "SHIPTODEALERDESC"
sfSNC.Cells(snc, 2) = "ŞEHİR"
sfSNC.Cells(snc, 3) = "VIN"
For knt = 1 To sonsat
deger = sfDTA.Cells(knt, 1)
    If IsNumeric(deger) = True And deger <> "" Then
        snc = snc + 1
        sfSNC.Cells(snc, 1) = sfDTA.Cells(knt, 5)
        sfSNC.Cells(snc, 2) = sfDTA.Cells(knt, 4)
        sfSNC.Cells(snc, 3) = sfDTA.Cells(knt, 3)
    End If
Next knt
's&#252;tun geni&#351;likleri
    Range("A1:C1").Font.Bold = True
    Columns("A:A").ColumnWidth = 20
    Columns("B:B").ColumnWidth = 50
    Columns("C:C").ColumnWidth = 20
'KENAR &#199;&#304;ZG&#304;LER&#304;
sfSncsonsat = sfSNC.[a65536].End(3).Row
    Range("A1:C" & sfSncsonsat).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

 

[sakoz]

Süper oldu... Ellerinize saglık HSAYAR üstadım...Saolun teşekkürler...