Birçok excel dosyasından bazı verileri alıp tek bir excel dosyası haline getirmek

[mabthera]

Merhabalar,
Ne kadar uğraştıysam da çözemediğim bir sorunum (Forumdaki tüm excel dosyalarını birleştirmek konularını da okudum) yüzünden sizlerden yardım istiyorum. Yardımcı olursanız memnun kalırım.

Sorunum şu:

Şirketlerin bilançolarının olduğu yaklaşık 250-300 tane ayrı excel dosyası var (kap.gov.tr den indirilmiş). Ben bu excel dosyalarından A1 hücresinde yazan veriyi ,"nakit ve benzerleri" satırı ile "FAALİYET KARI/ZARARI" satırlarını alıp hepsini tek bir excel dosyasında toplamak istiyorum. Bu mümkün müdür?

Eğer bunun bir yöntemi varsa çok makbule geçer. Teşekkürler...

Ekte 3 tane verileri almak istediğim dosya örneği var..

 

[Korhan Ayhan]

Merhaba,

Forumumuza hoşgeldiniz.

İlk olarak masaüstünde bir klasör oluşturun.
Daha sonra boş bir excel dosyasınız ANA_DOSYA adıyla bu klasör altına kayıt edin.
Bahsettiğiniz 300 excel dosyasınıda bu klasör altına aktarın.
ANA_DOSYA isimli dosyayı açın.
ALT+F11 tuşlarına basın.
Kod penceresi açılacaktır.
INSERT menüsünden "Module" seçeneğine tıklayın. Boş bir modül eklenecektir.
Sağ taraftaki boş beyaz ekrana aşağıdaki kodu uygulayın.

Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim Yol As String, Dosya As String
    Dim K1 As Workbook, K2 As Workbook
    Dim X As Integer, Satır As Integer
    On Error Resume Next
 
    Set K1 = ThisWorkbook
    Yol = K1.Path
    Dosya = Dir(Yol & "\*.xls")
    Satır = 2
 
    Application.ScreenUpdating = False
 
    Do
        If Dosya <> "" And Dosya <> "ANA_DOSYA.xls" Then
            DoEvents
            Set K2 = Workbooks.Open(Yol & "\" & Dosya, False, False)
            K1.Sheets("Sayfa1").Range("A" & Satır & ":A" & Satır + 1) = K2.Sheets("Sheet1").Range("A1")
 
            For X = 6 To 1000
                If K2.Sheets("Sheet1").Cells(X, 1) = "  Nakit ve Benzerleri" Then
                    K1.Sheets("Sayfa1").Cells(Satır, 2) = "  Nakit ve Benzerleri"
                    K1.Sheets("Sayfa1").Cells(Satır, 3) = K2.Sheets("Sheet1").Cells(X, 2)
                    K1.Sheets("Sayfa1").Cells(Satır, 4) = K2.Sheets("Sheet1").Cells(X, 3)
                    K1.Sheets("Sayfa1").Cells(Satır, 5) = K2.Sheets("Sheet1").Cells(X, 4)
                    Satır = Satır + 1
                ElseIf K2.Sheets("Sheet1").Cells(X, 1) = "  FAALİYET KARI/ZARARI" Then
                    K1.Sheets("Sayfa1").Cells(Satır, 2) = "  FAALİYET KARI/ZARARI"
                    K1.Sheets("Sayfa1").Cells(Satır, 3) = K2.Sheets("Sheet1").Cells(X, 2)
                    K1.Sheets("Sayfa1").Cells(Satır, 4) = K2.Sheets("Sheet1").Cells(X, 3)
                    K1.Sheets("Sayfa1").Cells(Satır, 5) = K2.Sheets("Sheet1").Cells(X, 4)
                    Satır = Satır + 1
                    Exit For
                End If
 
            Next
 
            K2.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
 
    K1.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
 
    Set K1 = Nothing
    Set K2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Daha sonra dosyanızı kayıt edip kapatın. Tekrar açın. Açarken makroları etkinleştirin.

ALT+F8 tuşuna basn ve "ÇALIŞTIR" komutunu seçin. Dilerseniz bu işlemi bir buton yardımıylada yapabilirsiniz.

Butona makro atamak için linki inceleyin.

Sayfada düğme oluşturmak ve makro atamak

Böylece klasör altındaki tüm dosyalardan bilgiler aktarılacaktır.

Uygulamalı örnek dosyalar ektedir.

 

[mabthera]

Cevabınız için çok teşekkür ederim.
dediklerinizi aynen yaptım yalnız 1-2 sorunla karşılaştım.
1.Kodu uygulayıp kaydederken 1 nolu resimdeki hata ile karşılaştım ve dosya uzantısı .xlsm olan dosya şeklinde kaydettim.
2. Daha sonra bu dosyası çalıştırıp dediklerinizi yapmaya çalıştım ve sonuçta ekteki dosyadaki gibi oldu. Sizin örnek olarak gönderdiğiniz dosyaya benzemeyen bir görünüm ortaya çıktı.
3. Sizin gönderdiğiniz örnek dosya tam istediğim gibi. yalnız onda da bir eksiklik olmuş sanırım.
FAALİYET KAR/ZARAR yazan satırda 2 sütunda daha veriler var. Yani F ve G sütununda da veriler olması gerekiyor. Ancak ben onları göremedim.

Yardımınız için gerçekten tekrar teşekkür ediyorum.

 

[Korhan Ayhan]

Merhaba,

Dosyaları foruma eklerken "xls" uzantılı eklediğiniz için profilinizdeki "2010" ifadesine dikkat etmemiştim.

Kod içindeki aşağıdaki satırları değiştirin.

Dosya = Dir(Yol & "\*.xls[COLOR=red]x[/COLOR]")

If Dosya <> "" And Dosya <> "ANA_DOSYA.xls[COLOR=red]m[/COLOR]" Then

Size nasıl yapacağınızı ifade ederken ilk satırdaki başlıkları belirtmemiştim. Bunuda kendiniz yaparsınız diye düşünmüştüm.

Hangi sütunları almak istediğinizi belirtmediğiniz için ben sadece D sütununa kadar olan kısmı alacak kodu verdim. Aşağıdaki satırları ekleyerek F-G sütunlarınıda aktarabilirsiniz.

K1.Sheets("Sayfa1").Cells(Satır, 6) = K2.Sheets("Sheet1").Cells(X, 5)
K1.Sheets("Sayfa1").Cells(Satır, 7) = K2.Sheets("Sheet1").Cells(X, 6)

Bu kodları kod içindeki aşağıdaki satırın üstüne ekleyin. Kırmızı renkli satırın hemen üstüne ekleyin.

[COLOR=red]Satır = Satır + 1[/COLOR]
Exit For

Benim eklediğim dosya üzerinde uygularsanız sorun yaşamazsınız.

 

[mabthera]

Sanırım bu sefer oldu.
Ek olarak birşey daha sormak istiyorum.
Şimdi bu alacağımız parametrelere başka satırlar da ekleyebilirmiyiz.
Yani diyelimki "satış gelirleri" , "kısa vadeli yükümlülükler" , uzun vadeli yükümlülükler" satırlarını da eklemek istesek nasıl bir yöntem izlememiz gerekir?
Çok sağolun...

 

[Korhan Ayhan]

Merhaba,

Dilediğiniz kadar çoğaltabilirsiniz.

Aşağıdaki satırdaki +1 değeri kapalı dosyalardaki A1 hücresindeki şirket ismini 2 satıra yazmaktadır. Çünkü sizin kriter sayısınız 2 adetti. Son mesajınızdaki kriterlerle toplam 5 adet oluyor. Bu durumda +4 yazmanız gerekiyor.

K1.Sheets("Sayfa1").Range("A" & Satır & ":A" & Satır [COLOR=red]+ 1[/COLOR]) = K2.Sheets("Sheet1").Range("A1")

Ayrıca alttaki satırı çoğaltmanız gerekiyor. Siz kırmızı bölümdeki kriter yerine yeni kriterlerinizi yazmalısınız.

ElseIf K2.Sheets("Sheet1").Cells(X, 1) = "  [COLOR=red]FAALİYET KARI/ZARARI[/COLOR]" Then
   K1.Sheets("Sayfa1").Cells(Satır, 2) = " [COLOR=red] FAALİYET KARI/ZARARI[/COLOR]"
   K1.Sheets("Sayfa1").Cells(Satır, 3) = K2.Sheets("Sheet1").Cells(X, 2)
   K1.Sheets("Sayfa1").Cells(Satır, 4) = K2.Sheets("Sheet1").Cells(X, 3)
   K1.Sheets("Sayfa1").Cells(Satır, 5) = K2.Sheets("Sheet1").Cells(X, 4)
   Satır = Satır + 1

Son olarak "Exit For" ifadesini son kriterinize ait "ElseIf" bloğunun en alt satırına yazmalısınız.

Bu adımları düzgün takip ederseniz sorun çıkmaması gerekir.

 

[mabthera]

Korhan bey
Teşekkürler.
Size özel mesaj gönderdim.
Lütfen cevaplayabilir misiniz?