• DİKKAT

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

Bu formüldeki hata nerede..

Y

yorum.halil

Katılım
16 Aralık 2007
Mesajlar
151
Excel Vers. ve Dili
Office 2007
Arkadaşlar bir üstadımızın dosyasını kendime uyarlamaya çalıştım fakat makro ERTAN isimli sayfada çalışırken BİLGİ isimli sayfada çalışmıyor...

Çalışıyor fakat ERTAN isimli sayfadaki verileri alması gerekirlen "BİLGİ" isimli sayfaki verileri alıyor.. Konu ile ilgili gerekli açıklamalar dosyada mevcut. Ama sanırım aşağıda ki satırlarda bir düzenleme yapılması gerekli. Help.... :)

For x = 1 To Sheets("ERTAN").Range("O1")
For y = 1 To 11
Genişletmek için tıkla ...
 
Merhaba,

Sonucu tam denemedim, siz dener misiniz?

Kod: 
Sub ortaktxtolustur()
ActiveWorkbook.Save
Open Sheets("bilgi").Range("b1") & Sheets("bilgi").Range("b2") & ActiveSheet.Name & ".txt" For Output As #1
Dim al(100, 11)
[B][COLOR=red]Set e = Sheets("ERTAN")[/COLOR][/B]
For x = 1 To [COLOR=red][B]e.[A65536].End(3).Row[/B][/COLOR]
    For y = 1 To 11
        al(x, y) = [B][COLOR=red]e.[/COLOR][/B]Cells(x, y)
    Next
 
    al(x, 11) = Replace(al(x, 11), ".", ",")
    kayit = al(x, 1) & Chr(9) & al(x, 2) & Chr(9) & al(x, 3) & Chr(9) & al(x, 4) & Chr(9) & al(x, 5) & Chr(9) & al(x, 6) & Chr(9) & al(x, 7) & Chr(9) & al(x, 8) & Chr(9) & al(x, 9) & Chr(9) & al(x, 10) & Chr(9) & al(x, 11)
    Print #1, kayit
Next
    Close #1
    MsgBox " Aktarım yapıldı.", vbInformation, " Bilgilendirme"
End Sub
 
Üstadım verdiğin kodlama oldu. Tşk. Elinize sağlık.....Sizden bir ricam daha olacak... txt dosyasının kaydedileceği yeri B1 hücresinde belirtiyoruz. Ama "B1" hücresinde belirlilen klasör olmadığı zaman "....... isimli klasör yok açılsın mı" gibi bir bölüm eklemek mümkünmü acaba...

Birde en sondaki MsgBox bölümünde "AKTARIM YAPILDI" yerine "...... FİRMASININ AKTARIMI YAPILDI" yapabilirmiyiz. Yani mesaj bölümünde firmanın ismide yazsın.. Sizin eklediğiniz koda göre yapılan dosya ektedir. İlginiz için şimdiden tşk. ederim.
 
Son düzenleme:
İyi geceler,

Kodları dener misiniz?


Kod: 
Sub ortaktxtolustur()
Sheets("BILGI").Select
If Right([B1], 1) <> "\" Then [B1] = [B1] & "\"
If Dir([B1]) = "" Then
    Evet = InputBox([B1] & " Adl&#305; Dizini Bulamad&#305;m, Olu&#351;turay&#305;m m&#305;? (E/H)", "Klas&#246;r Olu&#351;turma", "H")
    If Evet = "E" Or Evet = "e" Then
        MkDir ([B1])
    Else
        MsgBox [B1] & " Klas&#246;r&#252;n&#252; A&#231;&#305;ktan Sonra &#199;al&#305;&#351;mak &#220;zere Ho&#351;&#231;akal&#305;n&#305;z..."
        Exit Sub
    End If
End If
ActiveWorkbook.Save
Open Sheets("BILGI").Range("b1") & Sheets("BILGI").Range("b2") & "-ICMAL" & ".txt" For Output As #1
Dim al(20, 11)
Set e = Sheets("ERTAN")
For x = 1 To e.[A65536].End(3).Row
    For y = 1 To 11
        al(x, y) = e.Cells(x, y)
    Next
 
    al(x, 11) = Replace(al(x, 11), ".", ",")
    kayit = al(x, 1) & Chr(9) & al(x, 2) & Chr(9) & al(x, 3) & Chr(9) & al(x, 4) & Chr(9) & al(x, 5) & Chr(9) & al(x, 6) & Chr(9) & al(x, 7) & Chr(9) & al(x, 8) & Chr(9) & al(x, 9) & Chr(9) & al(x, 10) & Chr(9) & al(x, 11)
    Print #1, kayit
 
Next
    Close #1
Open Sheets("BILGI").Range("b1") & Sheets("BILGI").Range("b2") & "-LISTE" & ".txt" For Output As #1
Set e = Sheets("LISTE")
For f = 1 To e.[A65536].End(3).Row
    For g = 1 To 11
        al(f, g) = e.Cells(f, g)
    Next
    al(f, 11) = Replace(al(f, 11), ".", ",")
    kayit = al(f, 1) & Chr(9) & al(f, 2) & Chr(9) & al(f, 3) & Chr(9) & al(f, 4) & Chr(9) & al(f, 5) & Chr(9) & al(f, 6) & Chr(9) & al(f, 7) & Chr(9) & al(f, 8) & Chr(9) & al(f, 9) & Chr(9) & al(f, 10) & Chr(9) & al(f, 11)
    Print #1, kayit
Next
    Close #1
     MsgBox [B2] & " Firmas&#305;n&#305;n Bilgileri Aktar&#305;ld&#305;....", vbInformation, " BILGIlendirme"
End Sub
 
Üstadım verdiğin kodlar oldu. Siz değerli üstadlarımdan son bir şey daha isteyeceğim. Txt dosyasınının oluşturulduğu sayfa başka bir sayfadan veri alacak... Ama ilgili satır o ay işlem görmediği zaman satır boş kalacak...

Sizlerden isteğim şu.. Txt dosyasını oluştururken boş satırlar iptal edilebilirmi... Yada bir nev'i sıralama yaptırabilirmiyiz... Ekteki dosyada bununla ilgili açıklama ve örnekler var... Yardımlarımız için şimdiden tşk ediyorum..
 
Merhaba,

Bo&#351; sat&#305;rlar&#305; sildirsek san&#305;r&#305;m olur.

Kod: 
Sub ortaktxtolustur()
[B][COLOR=red]On Error Resume Next
[/COLOR][/B]Sheets("BILGI").Select
If Right([B1], 1) <> "\" Then [B1] = [B1] & "\"
If Dir([B1]) = "" Then
    Evet = InputBox([B1] & " &#304;S&#304;ML&#304; KLAS&#214;R BULUNAMADI.          &#350;&#304;MD&#304; A&#199;MAK &#304;STERM&#304;S&#304;N&#304;Z ? (EVET/HAYIR)", "Klas&#246;r Olu&#351;turma", "H")
    If Evet = "E" Or Evet = "e" Then
        MkDir ([B1])
    Else
        MsgBox [B1] & " KLAS&#214;R&#220; A&#199;ILMADAN &#304;&#350;LEME DEVAM EDEMEZS&#304;N&#304;Z"
        Exit Sub
    End If
End If
ActiveWorkbook.Save
Open Sheets("BILGI").Range("b1") & Sheets("BILGI").Range("b2") & "-ICMAL" & ".txt" For Output As #1
Dim al(20, 11)
Set e = Sheets("ERTAN")
    
[B][COLOR=red]e.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete[/COLOR][/B]
For x = 1 To e.[A65536].End(3).Row
    For y = 1 To 11
        al(x, y) = e.Cells(x, y)
    Next
 
    al(x, 11) = Replace(al(x, 11), ".", ",")
    kayit = al(x, 1) & Chr(9) & al(x, 2) & Chr(9) & al(x, 3) & Chr(9) & al(x, 4) & Chr(9) & al(x, 5) & Chr(9) & al(x, 6) & Chr(9) & al(x, 7) & Chr(9) & al(x, 8) & Chr(9) & al(x, 9) & Chr(9) & al(x, 10) & Chr(9) & al(x, 11)
    Print #1, kayit
 
Next
    Close #1
Open Sheets("BILGI").Range("b1") & Sheets("BILGI").Range("b2") & "-LISTE" & ".txt" For Output As #1
Set e = Sheets("LISTE")
For f = 1 To e.[A65536].End(3).Row
    For g = 1 To 11
        al(f, g) = e.Cells(f, g)
    Next
    al(f, 11) = Replace(al(f, 11), ".", ",")
    kayit = al(f, 1) & Chr(9) & al(f, 2) & Chr(9) & al(f, 3) & Chr(9) & al(f, 4) & Chr(9) & al(f, 5) & Chr(9) & al(f, 6) & Chr(9) & al(f, 7) & Chr(9) & al(f, 8) & Chr(9) & al(f, 9) & Chr(9) & al(f, 10) & Chr(9) & al(f, 11)
    Print #1, kayit
Next
    Close #1
     MsgBox [B2] & " F&#304;RMASINA A&#304;T TXT DOSYASI BA&#350;ARI &#304;LE OLU&#350;TURULDU", vbInformation, "TEBR&#304;KLER"
End Sub
 
Son düzenleme:
Üstadım.. Satırlar arasında boşluk olduğu zaman sorun yok düzgün bir şekilde boş satırları siliyor... Fakat boşluk olmadığı zaman ise "Run-time error 1004" hatasını veriyor...
 
h&#305;mmm onu atlam&#305;&#351;&#305;m.

O sat&#305;r&#305;n ba&#351;&#305;na yada makronun ba&#351;&#305;na On Error Resume Next ibaresini ekler misiniz.
 
&#220;stad&#305;m eline eme&#287;ine sa&#287;l&#305;k... valla h&#305;z&#305;r gibi yeti&#351;tin....
 
G&#252;le g&#252;le kullan&#305;n&#305;z, yukar&#305;daki mesaj&#305; da d&#252;zeltmi&#351; olal&#305;m da, eksik olmas&#305;n.
 
Arkadaşlar öncelikle böyle bir forumu keşfettiğim için çok memnun olduğumu belirtmek isterim. Gerçekten çok güzel dosyalar var... Muhasebe işi ile uğraştığım için bu dosya benimde çok işme yarayacak. Bu nedenle herkese tekrar tşk. ederim. Yalnız ben bu dosya ile ilgili ufak bir ricam olacak..

B1 hücresine göre klasörü açarken EVET/HAYIR diye sormadan direk açılması için ne yapmamız gerekir... YAni klsör yoksa oluştursun... varsa direk dosyaları onun içine oluştursun...
 
Birde &#252;stad&#305;m san&#305;r&#305;m bir eksik daha var...halil arkada&#351;&#305;m&#305;z fark etmedi san&#305;r&#305;m. Halil arkada&#351;&#305;m&#305;z&#305;nda dedi&#287;i gibi ERTAN VE L&#304;STE isimli sayfalar ba&#351;ka sayfalardan veri alacak.. ama txt dosyas&#305; olu&#351;tururken sat&#305;rlar&#305; sildi&#287;i i&#231;in otomatikmen verileri almas&#305; i&#231;in yaz&#305;lan form&#252;lleride siliyor... Yani bunun ba&#351;ka bir yolu olmal&#305;.
 
Merhaba,

Dizin yoksa hemen dizini olu&#351;turur.
Bo&#351; sat&#305;rlar&#305; silmeden liste olu&#351;turur.


Kod: 
Sub ortaktxtolustur()
On Error Resume Next
Sheets("BILGI").Select
If Right([B1], 1) <> "\" Then [B1] = [B1] & "\"
If Dir([B1]) = "" Then MkDir ([B1])
ActiveWorkbook.Save
Open Sheets("BILGI").Range("b1") & Sheets("BILGI").Range("b2") & "-ICMAL" & ".txt" For Output As #1
Dim al(20, 11)
Set e = Sheets("ERTAN")
 
For x = 1 To e.[A65536].End(3).Row
   [COLOR=red][B] If e.Cells(x, "A") <> "0" And e.Cells(x, "A") <> "" Then[/B][/COLOR]
       For y = 1 To 11
           al(x, y) = e.Cells(x, y)
       Next
 
       al(x, 11) = Replace(al(x, 11), ".", ",")
       kayit = al(x, 1) & Chr(9) & al(x, 2) & Chr(9) & al(x, 3) & Chr(9) & al(x, 4) & Chr(9) & al(x, 5) & Chr(9) & al(x, 6) & Chr(9) & al(x, 7) & Chr(9) & al(x, 8) & Chr(9) & al(x, 9) & Chr(9) & al(x, 10) & Chr(9) & al(x, 11)
       Print #1, kayit
    End If
Next
    Close #1
Open Sheets("BILGI").Range("b1") & Sheets("BILGI").Range("b2") & "-LISTE" & ".txt" For Output As #1
Set e = Sheets("LISTE")
For f = 1 To e.[A65536].End(3).Row
   [COLOR=red][B] If e.Cells(f, "A") <> "0" And e.Cells(f, "A") <> "" Then[/B][/COLOR]
        For g = 1 To 11
            al(f, g) = e.Cells(f, g)
        Next
        al(f, 11) = Replace(al(f, 11), ".", ",")
        kayit = al(f, 1) & Chr(9) & al(f, 2) & Chr(9) & al(f, 3) & Chr(9) & al(f, 4) & Chr(9) & al(f, 5) & Chr(9) & al(f, 6) & Chr(9) & al(f, 7) & Chr(9) & al(f, 8) & Chr(9) & al(f, 9) & Chr(9) & al(f, 10) & Chr(9) & al(f, 11)
        Print #1, kayit
    End If
Next
    Close #1
     MsgBox [B2] & " F&#304;RMASINA A&#304;T TXT DOSYASI BA&#350;ARI &#304;LE OLU&#350;TURULDU", vbInformation, "TEBR&#304;KLER"
End Sub
 
Son düzenleme:
&#252;stad&#305;m acemix06 karde&#351;imizin dedi&#287;i gibi ertan ve bilgi sayfalar&#305; ba&#351;ka yerden veri al&#305;yor bu nedenle form&#252;ll&#252; olacak... Onun dedi&#287;i gibi d&#252;zeltmi&#351;sin... t&#351;k.. nede olsa akl&#305;n yolu birdir...

E&#287;er k&#305;zmazsan&#305;z bizden kaynaklanan ufak bir hata daha var... Onu d&#252;zeltirseniz sevirinim... Dedi&#287;imiz gibi h&#252;creler form&#252;ll&#252; olaca&#287;&#305; i&#231;in veri ald&#305;&#287;&#305; yer bo&#351;sa h&#252;cre "0" S&#305;f&#305;r olarak yaz&#305;yor ve txt dosyas&#305;n&#305;da buna g&#246;re olu&#351;turuyor...

M&#252;mk&#252;nse txt dosyas&#305;n&#305; olu&#351;tururken bo&#351; sat&#305;r olarak de&#287;ilde de&#287;ilde "0" S&#305;f&#305;r yazan sat&#305;rlar&#305; almadan olu&#351;turabilirmi..

Birde varsa olu&#351;turmas&#305;n yoksa olu&#351;tursun... &#199;&#252;nk&#252; klas&#246;rlerin i&#231;inde ba&#351;ka dosyalarda var.. Ama klas&#246;r&#252; her seferinde silip yeniden olu&#351;turdu&#287;u i&#231;in di&#287;er dosyalarda siliniyor :)

&#220;stad&#305;m bu arada hakk&#305;n&#305;z&#305; helal edin...
 
Son düzenleme:
Merhaba,

13. mesajda kırmızı olarak işaretlediğim satırın silinmesi gerekiyordu, onu unutmuşum.

Bu durumda A sütununda hücre boşsa text dosyasına o satırı yazmıyor zaten.

Dizin varsa o dizini zaten açmıyor. Dolayısı ile klasör ve içindeki dosyalar olduğu gibi duruyor, onlara dokunmaz. Ama ilgili text dosyası her seferinde yeniden oluşturur.
 
Üstad dediğin gibi "A" sütünu boşsa txt dosyası oluştururken sorun olmuyor. Fakat hücre formüllü olduğu için ve veri aldığı hücrede değer olmadığı için A sütunu ve yanındaki hücreler "0" olarak veriyor. Ekteki örnek txt dosyasının 3.satırına bakarsanız anlarsınız. Tşk..
 
Merhaba,

Sizin g&#246;nderdi&#287;iniz dosyada hi&#231; form&#252;l g&#246;r&#252;nmedi&#287;i i&#231;in her olas&#305;l&#305;&#287;&#305; d&#252;&#351;&#252;nmek zor tabi, hele hele bilmeden bir&#351;eyleri &#231;&#246;zmek daha da zor :).

Bir deneme daha yapt&#305;m, 13. mesajdaki kodlar&#305; deneyebilir misiniz?
 
Necdet Yeşertener' Alıntı:
Merhaba,

Sizin gönderdiğiniz dosyada hiç formül görünmediği için her olasılığı düşünmek zor tabi, hele hele bilmeden birşeyleri çözmek daha da zor :).

Bir deneme daha yaptım, 13. mesajdaki kodları deneyebilir misiniz?
Genişletmek için tıkla ...

Üstadım dosya henüz yapım aşamasında olduğu için formül işleri bitmedi.. Sayende büyük bir kısmı bitti.. Tamamı biter bitmez sizlerle paylaşacağım... Eline emeğine klavyene sağlık....

Ha bu arada dosyayı görmesende yaptığın denemeler başarılı :)
 
Tekrar merhaba,

&#350;imdi s&#305;ra kodlar&#305; k&#305;saltmaya geldi :) a&#351;a&#287;&#305;daki kodlar&#305; deneyebilir misiniz?

Kod: 
Sub ortaktxtolustur()
On Error Resume Next
Sheets("BILGI").Select
If Right([B1], 1) <> "\" Then [B1] = [B1] & "\"
If Dir([B1]) = "" Then MkDir ([B1])
ActiveWorkbook.Save
For i = 1 To 2
    If i = 1 Then
        Set e = Sheets("ERTAN")
        Ek = "-ICMAL"
    Else
        Set e = Sheets("LISTE")
        Ek = "-LISTE"
    End If
    Open [B1] & [B2] & Ek & ".txt" For Output As #1
    For x = 1 To e.[A65536].End(3).Row
        If e.Cells(x, "A") <> "0" And e.Cells(x, "A") <> "" Then
           Kay&#305;t = e.Cells(x, 1)
           For y = 2 To 11
                Kay&#305;t = Kay&#305;t & Chr(9) & e.Cells(x, y)
           Next
           Print #1, Kay&#305;t
        End If
    Next
        Close #1
Next i
     MsgBox [B2] & " F&#304;RMASINA A&#304;T TXT DOSYASI BA&#350;ARI &#304;LE OLU&#350;TURULDU", vbInformation, "TEBR&#304;KLER"
End Sub
 
Son düzenleme:
&#220;stad&#305;m..... Ankaral&#305; hem&#351;ehrim tekrar eline sa&#287;l&#305;k bende b&#246;yle bir &#351;ey isteyecektim ama inan y&#252;z&#252;m kalmad&#305;... Eeee ne demi&#351; atalar&#305;m&#305;z k&#246;r&#252;n istedi&#287;i bir g&#246;z Allah verdi iki g&#246;z.... Allah klavyene zeval vermesin....T&#351;k.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst