..:: Yevmiye Defteri Excel'e Dönüştürme ::..

[Ömer BARAN]

..:: Yevmiye Defteri'nden Excel'e ::..

Merhabalar !...

Makro bilmediğim için yardıma ihtiyacım var.
Ekte bir adet txt belge (muhasebe programından alınmış çıktı sayfa örneği) ve bir adet de açıklamalar yaptığım excel belgesi var.

Formüllerle örnek yaptım ve excel belgemde açıklamalar mevcut.

Destek ricamın sebebi şudur: veriler çok fazla satır şeklindedir ve formüllerle tümünü tamamladığımda ve belgede süz, süzülenlerin toplamı gibi işlemler yaptığımda çok fazla yavaşlama gibi sorunlarla karşılaşıyorum.

Ricam formüllerle elde ettiğim sonuçların txt belgesinden hareketle excel belgesine makro yoluyla aktarılması ve böylece excel belgesinin daha kullanışlı olmasının sağlanmasıdır.
İlgileneceklere şimdiden teşekkürler.

 

[halit3]

Merhabalar !...

Makro bilmediğim için yardıma ihtiyacım var.
Ekte bir adet txt belge (muhasebe programından alınmış çıktı sayfa örneği) ve bir adet de açıklamalar yaptığım excel belgesi var.

Formüllerle örnek yaptım ve excel belgemde açıklamalar mevcut.

Destek ricamın sebebi şudur: veriler çok fazla satır şeklindedir ve formüllerle tümünü tamamladığımda ve belgede süz, süzülenlerin toplamı gibi işlemler yaptığımda çok fazla yavaşlama gibi sorunlarla karşılaşıyorum.

Ricam formüllerle elde ettiğim sonuçların txt belgesinden hareketle excel belgesine makro yoluyla aktarılması ve böylece excel belgesinin daha kullanışlı olmasının sağlanmasıdır.
İlgileneceklere şimdiden teşekkürler.

Bu kadarcığı işinizi görür herhalde

kod:

Sub veri_al()

Dim i As Long, deg As String, sat As Long, deg2, k As Byte, dosya
Range("A1:N65536").Clear

dosya = Application.GetOpenFilename(filefilter:="Metin dosyaları(*.txt),(*.txt)", Title:="Bir metin dosyası seçiniz.")
If dosya = False Then Exit Sub

Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
    Line Input #1, deg
    sat = sat + 1
    
    deg = Replace(Trim(deg), "-", Chr(9))
    deg = Replace(Trim(deg), "  ", Chr(9))
    deg2 = Split(deg, vbTab)
    k = 0
    For i = 0 To UBound(deg2)
    If deg2(i) <> "" Then
        k = k + 1
        Cells(sat, k).Value = Trim(deg2(i))
        End If
    Next i
Loop
Close #1
Application.ScreenUpdating = True
MsgBox "veri.txt dosyasından veriler alınmıştır.", vbOKOnly + vbInformation, "uyarı"
    
End Sub

 

[Ömer BARAN]

Destek ricam devam ediyor.

Bu kadarcığı işinizi görür herhalde
kod:

Sub veri_al()
..........................................
..........................................   
End Sub

Merhabalar Sayın halit3 !...
İlgi ve destek için çok teşekkür ederim. Sonuca çok yaklaşmış oldum.

ANCAK;

Ekli excel belgesini yenileyerek ilave açıklamalar yaptım (txt belgesini excel belgesine kopyalayıp yapıştırarak) .

Formüllü çözüm sayfası da ekledim. Sanırım yazdığınız kodlara yapılacak biraz rötuş ile TAM BEKLEDİĞİM sonuca ulaştıracaksınız beni.

Kusura bakmayınız kod bilgisi olmayınca mecburen tüm işi sizin gibi kod bilgisi olanlardan rica etmiş oluyorum ama, şu aşamada yapabileceğim başka da bir şey yok maalesef.

Müsait olduğunuzda SİZ VEYA KOD BİLGİSİ OLAN DİĞER ARKADAŞLARDAN BİRİ bakabilirseniz sevinirim. Sağlıcakla.

 

[halit3]

Baya uğraştırdı sadece bu veriye göre 29 satırdaki değer kayık geliyor.
Sayfa1 deki komut düğmesine tıklayın

kod:

Private Sub CommandButton1_Click()
On Error Resume Next

Dim i As Long, deg1 As String, sat As Long, deg2, k As Byte, dosya
Range("A2:ı65536").Clear

dosya = Application.GetOpenFilename(filefilter:="Metin dosyaları(*.txt),(*.txt)", Title:="Bir metin dosyası seçiniz.")


yaz1 = 1
son1 = 0
sat = 1

If dosya = False Then Exit Sub
say = 0
Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
Line Input #1, deg1

If deg1 = "" Then GoTo atla

deg1 = Replace(Trim(deg1), "EF.AL.-USD-", "EF.AL.USD")
deg1 = Replace(Trim(deg1), " EF.AL.-EUR-", " EF.AL.EUR")
deg1 = Replace(Trim(deg1), "<00002-00002>Doviz Alis -", "<00002_00002>Doviz Alis")
deg1 = Replace(Trim(deg1), "<00002-00002>Doviz Satis-", "<00002_00002>Doviz Satis")
deg1 = Replace(Trim(deg1), "-", Chr(9))
deg1 = Replace(Trim(deg1), "  ", Chr(9))
deg1 = Replace(Trim(deg1), "Madde No :", "Madde No :" & Chr(9))
deg2 = Split(deg1, vbTab)

k = 3

deg3 = Split(deg1, "Madde No")
If UBound(deg3) > 0 Then
say = 1
End If

If Mid(deg1, 1, 3) = "Bor" Then GoTo atla
If Mid(deg1, 1, 9) = "Madde Top" Then GoTo atla


If say = 1 Then
sat = sat + 1

For i = 0 To UBound(deg2)
If Trim(deg2(i)) <> "" Then

k = k + 1
If k = 5 Then k = k + 1

Cells(sat, k).Value = Trim(deg2(i))
Cells(sat, 1).Value = 1

If Trim(deg2(i)) = "00002>Doviz Alis" Then i = i + 1
If Cells(sat, 4).Value = "Madde No :" Then

If k = 8 Then
son1 = 1
sut3 = Cells(sat, 6).Value
sut4 = Cells(sat, 7).Value
End If
End If

If son1 = 1 Then
Cells(sat, 2).Value = sut3
Cells(sat, 3).Value = Format(sut4, "dd/mm/yyyy")
End If


If k = 8 Then
If Cells(sat - 1, 4).Value = "" Then
Cells(sat - 2, 5).Value = Cells(sat - 2, 4).Value
Cells(sat - 2, 4).Value = ""
Cells(sat - 2, 9).Value = Cells(sat - 2, 8).Value
Cells(sat - 2, 8).Value = ""
End If
End If


If k = 8 Then Exit For

End If
Next i

End If

atla:

Loop
Close #1

son1 = Cells(Rows.Count, "b").End(3).Row
son2 = Cells(Rows.Count, "e").End(3).Row + 1

Range("A" & son1 - 2 & ":I" & son1).ClearContents
For r = son1 To 4 Step -1
aranan1 = Cells(r, "e").Value
If aranan1 <> "" Then
Range("A" & r + 1 & ":I" & r + 2).Delete Shift:=xlUp
End If
Next
Range("A2:I3").Delete Shift:=xlUp

Application.ScreenUpdating = True
MsgBox "dosyadan veriler alınmıştır.", vbOKOnly + vbInformation, "uyarı"


End Sub

 

[halit3]

Text dosyasındaki nesnelerin karekterleri aynı olduğu için parçaal kodu ile yapılmıştır.

kod:

kod aşağıdaki mesajda

 

[halit3]

5 nolu mesajdaki kodu düzelttim.

Private Sub CommandButton1_Click()
say = 0
say2 = 0
Range("A2:ı65536").ClearContents

dosya = Application.GetOpenFilename(filefilter:="Metin dosyaları(*.txt),(*.txt)", Title:="Bir metin dosyası seçiniz.")
'dosya = "C:\Documents and Settings\Administrator\Desktop\aa\bb.txt"
If dosya = False Then Exit Sub

Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
Line Input #1, deg1

If Mid(Trim(deg1), 4, 8) = "Madde No" Then
say = 1
End If

If say = 1 Then
say2 = say2 + 1

If deg1 = "" Then GoTo atla

If Mid(Trim(deg1), 1, 3) = "---" Then GoTo atla
If Mid(WorksheetFunction.Trim(deg1), 1, 12) = "Madde Toplam" Then GoTo atla
If Len(WorksheetFunction.Trim(deg1)) < 0 Then GoTo atla


yer1 = Cells(Rows.Count, "d").End(3).Row + 1
yer2 = Cells(Rows.Count, "e").End(3).Row + 1
If yer1 > yer2 Then
sat = yer1
Else
sat = yer2
End If

If Mid(Trim(deg1), 1, 2) = "--" Then
yaz1 = Trim(Mid(deg1, 15, 5))
yaz2 = Trim(Mid(deg1, 22, 10))
Cells(sat, 2) = yaz1
Cells(sat, 2) = yaz2

Else

If Mid(deg1, 1, 1) <> " " Then
If say2 > 2 Then
Cells(sat, 4) = Trim(Mid(deg1, 1, 26))
End If
Cells(sat, 6) = Trim(Mid(deg1, 27, 29))
Cells(sat, 7) = Trim(Mid(deg1, 56, 37))
Cells(sat, 8) = Trim(Mid(deg1, 95, 26))

Else
Cells(sat, 5) = Trim(Mid(deg1, 14, 6))
Cells(sat, 6) = Trim(Mid(deg1, 27, 29))
Cells(sat, 7) = Trim(Mid(deg1, 56, 37))
Cells(sat, 9) = Trim(Mid(deg1, 110, 20))
End If

End If
Cells(sat, 1) = 1 ' sıra no
Cells(sat, 2) = yaz1
Cells(sat, 3) = yaz2
End If

atla:

Loop
Close #1

son1 = Cells(Rows.Count, "b").End(3).Row

Range("A" & son1 & ":I" & son1).ClearContents
Application.ScreenUpdating = True
MsgBox "veriler alınmıştır.", vbOKOnly + vbInformation, "uyarı"
End Sub

 

[halit3]

Dosyanız burada

 

[Ömer BARAN]

Dosyanız burada

Merhabalar Halit Bey!...

Sizin gibi bir kaç "Destek Ekibi" mensubu veya Site Yönetici'sinin cevap verdiği ( özellikle VBA KOD konusunda ) konulara başkalarının bakıp yeni öneride bulunması olasılığı oldukça düşüyor. Bunun yanı sıra siz de sitede çevrim içi olarak çok vakit geçirmiyorsunuz ve size özel mesaj gönderilmesi de mümkün değil.

Bu yüzden, makronun oluşturduğu, ( ilk başta çok da anlayamadığım ve test edemediğim ) bazı sorunlu durumları konu sayfasına yazmak yerine yeni konu açmıştım.
Yanlış anlaşıldıysa kusura bakmayınız.

Söylediğim gibi sitede çevrim içi kalmadığınız için belki başkası öneride bulunur diye yeni konu açmıştım.

Dünden bu yana verdiğiniz kodu veri dosyamda örnekler yaparak test etmeye çalıştım.
Sanırım sorunlu durumların tümünü listeleyebildim ve sadece bu tür verileri içeren yeni bir txt belge oluşturup, makro kodun bunlar için oluşturduğu sonuçlar üzerinde görebildiğim sorunları açıkladım.

Bu yeni txt belge ve sorunlu sonuçları içeren xlsx belgeye göz atabilirseniz sevinirim.

KOD'da nasıl bir değişiklik yapılması gerektiğini anlayamadım.
Sağlıcakla.

 

[Efkan.]

Merhabalar !...

Makro bilmediğim için yardıma ihtiyacım var.
Ekte bir adet txt belge (muhasebe programından alınmış çıktı sayfa örneği) ve bir adet de açıklamalar yaptığım excel belgesi var.

Formüllerle örnek yaptım ve excel belgemde açıklamalar mevcut.

Destek ricamın sebebi şudur: veriler çok fazla satır şeklindedir ve formüllerle tümünü tamamladığımda ve belgede süz, süzülenlerin toplamı gibi işlemler yaptığımda çok fazla yavaşlama gibi sorunlarla karşılaşıyorum.

Ricam formüllerle elde ettiğim sonuçların txt belgesinden hareketle excel belgesine makro yoluyla aktarılması ve böylece excel belgesinin daha kullanışlı olmasının sağlanmasıdır.
İlgileneceklere şimdiden teşekkürler.

ömer abi yeni bir excel eklentisi çıkmış işine yarar mı ?

http://www.microsoft.com/tr-tr/download/details.aspx?id=39379

Excel için Microsoft Power Query, Excel'de veri keşfini, erişimini ve işbirliğini basitleştirerek self servis karar destek deneyimini katan bir Excel eklentisidir.

Excel için Microsoft Power Query, verileri keşfetmede, veri aktarımında ve Bilgi İşlemciler, BI uzmanları ile diğer Excel kullanıcıları için sorunsuz bir deneyim sağlayan yeni bir eklentidir.

Power Query ile yapabilecekleriniz:
Çalıştığınız kaynaktaki ilgilendiğiniz veriyi (örneğin ilişkili veritabanları, Excel, metin ve XML dosyalar, OData akışları, web sayfaları, Hadoop HDFS, vb.) tanımlama.
Excel içerisinden arama özelliğini kullanarak kuruluşunuzun içindeki(*) ve dışındaki ilgili verileri keşfetme.
Birden fazla tamamen ayrı kaynaklardaki verileri birleştirme ve Excel ya da Power Pivot gibi araçlarda ayrıntılı analizler yapmaya yönelik verileri hazırlamak için onları şekillendirme veya Power View ve Power Map gibi araçlarda görselleştirme.
Oluşturduğunuz sorguları kuruluşunuzdaki diğer kişilerle paylaşma, dolayısıyla onlarda Arama yoluyla kolaylıkla bulabilirler. (*)

 

[Ömer BARAN]

Sayın Halit Bey !...

Dosyanız burada

Merhabalar Halit Bey!...

#8 Mesajımda bir şeyler yazmıştım müsait olduğunuzda bakabilir misiniz?

 

[halit3]

Böyle sorularınız uzayıp gidiyor
göndermiş olduğunuz dosyadan ben bir şey anlamadım txt dosyasından almak istediğiniz veriyi örnek dosyanıza o şekilde ekeleyin

 

[halit3]

Bu kodu denermisiniz.

Private Sub CommandButton1_Click()

Range("A2:ı65536").ClearContents

dosya = Application.GetOpenFilename(filefilter:="Metin dosyaları(*.txt),(*.txt)", Title:="Bir metin dosyası seçiniz.")
'dosya = "C:\Documents and Settings\Administrator\Desktop\aa\bb.txt"
If dosya = False Then Exit Sub

Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
Line Input #1, deg1


deg3 = Split(deg1, "Sayfa No:")
If UBound(deg3) > 0 Then
deg5 = deg3(1)
End If


If deg1 = "" Then GoTo atla
If UBound(Split(deg1, "YEVMIYE DEFTERI")) > 0 Then GoTo atla
If UBound(Split(deg1, "Sayfa Toplam")) > 0 Then GoTo atla
If UBound(Split(deg1, "Bor‡lu")) > 0 Then GoTo atla
If UBound(Split(deg1, "Madde Top")) > 0 Then GoTo atla
If UBound(Split(deg1, "")) > 0 Then GoTo atla
If UBound(Split(deg1, "Madde Toplam")) > 0 Then GoTo atla




If Mid(Trim(deg1), 1, 3) = "---" Then GoTo atla
If Len(WorksheetFunction.Trim(deg1)) < 0 Then GoTo atla


    yer1 = Cells(Rows.Count, "d").End(3).Row + 1
    yer2 = Cells(Rows.Count, "e").End(3).Row + 1
    If yer1 > yer2 Then
    sat = yer1
    Else
    sat = yer2
    End If

        If Mid(Trim(deg1), 1, 2) = "--" Then
        yaz1 = Trim(Mid(deg1, 15, 5)) * 1
        yaz2 = Format(Trim(Mid(deg1, 22, 10)), "dd/mm/yyyy")
        Cells(sat, 2) = yaz1
        Cells(sat, 3) = yaz2
        Else
        
            If Mid(deg1, 1, 1) <> " " Then
            Cells(sat, 4) = Trim(Mid(deg1, 1, 26))
            Cells(sat, 6) = Trim(Mid(deg1, 27, 29))
            Cells(sat, 7) = Trim(Mid(deg1, 56, 37))
            Cells(sat, 8) = Trim(Mid(deg1, 95, 15))
            Else
            Cells(sat, 5) = Trim(Mid(deg1, 14, 6))
            Cells(sat, 6) = Trim(Mid(deg1, 27, 29))
            Cells(sat, 7) = Trim(Mid(deg1, 56, 37))
            Cells(sat, 9) = Trim(Mid(deg1, 110, 20))
            
             
            End If
        
        Cells(sat, 2) = yaz1
        Cells(sat, 3) = yaz2
        Cells(sat, 1) = deg5
        End If

atla:

Loop
Close #1

Application.ScreenUpdating = True
MsgBox "veriler alınmıştır.", vbOKOnly + vbInformation, "uyarı"
End Sub

 

[halit3]

12 nolu mesjdaki kod işinizi gördümü ?

 

[Ömer BARAN]

12 nolu mesjdaki kod işinizi gördümü ?

Halit Bey merhabalar, ilgi ve destek için teşekkür ederim.
Geç dönüş yaptım, kusura bakmayınız.
Detaylı kontrol imkanım olmadı ama sanırım bir kaç sorunlu durum kaldı.
Önemli konu olduğundan ve veri yığını büyük olduğundan,
şöyle sakin kafayla ve gerçek verilerle test edip mutlaka dönüş yaparak sizi bilgilendiririm.

Sağlıcakla kalınız.