Yine veri aktarımı

[soby53]

01.xlsm....48.xlsm isimlerinde 48 adet çalışma sayfası var. Her birinin h1-h23 arası hücrelerini kontrol edip, eğer bir değer varsa bunu icmal sayfasına alt alta yazıp sıralamam gerekiyor.
Nasıl yapabilirim.

 

[PLİNT]

Merhaba
Aşağıdaki makroyu deneyin.
Makronun bulunduğu dosya; öteki dosyaların yanında olmalı,
veri alınacak sayfa "Sayfa1" ve aktarılacak sütun "A"
siz ayarlayın.

Sub Aktar()
Dim a, c, b As Integer, dosya As String
b = 2
For a = 1 To 48
dosya = a & ".xlsm"
[COLOR="RoyalBlue"]If a < 10 Then dosya = "0" & dosya[/COLOR]
For c = 1 To 23
If ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & dosya & "][COLOR="Red"]Sayfa1[/COLOR]'!R" & c & "C8") <> 0 Then
Cells(b, "[COLOR="red"]A[/COLOR]").Value = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & dosya & "][COLOR="red"]Sayfa1[/COLOR]'!R" & c & "C8")
b = b + 1
End If: Next: Next
End Sub

 

[ÖmerBey]

Aşağıdaki makro kodunu kullanabilirsiniz.
Kırmızı kısımlara ve açıklamalara dikkat ediniz. Kırmızı kısımları kendinize göre düzenleyiniz.

Sub KOD()
Application.ScreenUpdating = False
Set w1 = ThisWorkbook
yol = "[COLOR="Red"]C:\Yeni klasör\[/COLOR]" 'Çalışma sayfalarının yer aldığı klasör
For a = 1 To 48
    If Len(a) = 1 Then
        Set w2 = Workbooks.Open(yol & 0 & a & ".xlsm")
    ElseIf Len(a) = 2 Then
        Set w2 = Workbooks.Open(yol & a & ".xlsm")
    End If
    For b = 1 To 23
        If w2.Sheets(1).Cells(b, "H") <> "" Then
            w1.Sheets("[COLOR="red"]icmal[/COLOR]").Cells(w1.Sheets("[COLOR="red"]icmal[/COLOR]").Range("[COLOR="red"]A[/COLOR]65500").End(3).Row + 1, "[COLOR="Red"]A[/COLOR]") = w2.Sheets(1).Cells(b, "H") 'İcmal sayfası A sütunundaki son dolu hücrenin altına yazar.
        End If
    Next
    w2.Close
Next
Application.ScreenUpdating = True
End Sub

 

[soby53]

Sayın mucit77 Çok teşekkür ederim. Gayet güzel çalıştı. 2. döngü içerisine bir ilave daha yapmam gerekecek H(b) doluysa I(b) yi de yan sütuna yaz gibi.

Sayın PLİNT sizin makroyu da denedim ama yolu tam olarak nasıl girmeliyim. çalıştırınca belgelerim klasörünü açıyor.

 

[şehiriçi]

sayın mucit 77 benimde buna benzer bir sorum olacak mümkünse ;
ekteki dosyada icmal sayfasında sorumu yazdım

 

[ÖmerBey]

Sayın mucit77 Çok teşekkür ederim. Gayet güzel çalıştı. 2. döngü içerisine bir ilave daha yapmam gerekecek H(b) doluysa I(b) yi de yan sütuna yaz gibi.

    For b = 1 To 23
        If w2.Sheets(1).Cells(b, "H") <> "" Then
            With w1.Sheets("icmal").Cells(w1.Sheets("icmal").Range("A65500").End(3).Row + 1, "A")
                .Value = w2.Sheets(1).Cells(b, "H")
                [COLOR="Red"].Offset(0, 1) = w2.Sheets(1).Cells(b, "I")[/COLOR]
            End With
        End If
    Next

 

[ÖmerBey]

sayın mucit 77 benimde buna benzer bir sorum olacak mümkünse ;
ekteki dosyada icmal sayfasında sorumu yazdım

Soruda verilen para yazsın demişsiniz, örneğe kaç kg olduğunu yazmışsınız. Tarihe göre verilen paraları getiren kod aşağıdadır.

Sub KOD()
Set s1 = Sheets("icmal")
s1.Range("A2:C65000").ClearContents
For Each s2 In Sheets
    If s2.Name <> s1.Name Or s2.Name <> "özet" Then
        For a = 3 To 19
            If s2.Cells(a, "F") = s1.Range("A1") Then
                With s1.Cells(s1.Range("A65500").End(3).Row + 1, "A")
                    .Value = s2.Range("B1")
                    .Offset(0, 1) = s2.Cells(a, "F")
                    .Offset(0, 2) = s2.Cells(a, "E")
                End With
            End If
        Next
    End If
Next
End Sub

 

[PLİNT]

Sayın PLİNT sizin makroyu da denedim ama yolu tam olarak nasıl girmeliyim. çalıştırınca belgelerim klasörünü açıyor.

Merhaba
Yukarıdaki kodda dosya yolu yazmayacaksınız.
Verilerin alınacağı dosyalarla (sayfalarla) aynı klasör içinde bulunacak.
Dosyalar açılmadan veriler gelecektir.

"C:\Deneme" yolu da ( ("),(') tırnaklara dikkat ederek) şöyle yazabilirsiniz.

ExecuteExcel4Macro("'C:\Deneme\[" & dosya & "]Sayfa1'!R" & c & "C8")

"I" sütunundanda veri alması içinde:

Sub Aktar()
Dim a, c, b As Integer, dosya As String
b = 2
For a = 1 To 48
dosya = a & ".xlsm"
For c = 1 To 23
If ExecuteExcel4Macro("'C:\Deneme\[" & dosya & "]Sayfa1'!R" & c & "C8") <> 0 Then
Cells(b, "A").Value = ExecuteExcel4Macro("'C:\Deneme\[" & dosya & "]Sayfa1'!R" & c & "C8")
Cells(b, "B").Value = ExecuteExcel4Macro("'C:\Deneme\[" & dosya & "]Sayfa1'!R" & c & "C9")
b = b + 1
End If: Next: Next
End Sub

 

[soby53]

Size de ço teşekkürler sayın PLİNT. sizin makro çok daha hızlı sonuç üretti. C8,C9 un kolonlar olduğunu çözünce ;-) istediğim kadar sütun almayı becerdim. Ancak sabit B3 değerini de (kişi adı var) yan sütuna almayı beceremedim.
Cells(3, "A").Value = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & dosya & "]Sayfa1'!R" & c & "C2")
şeklinde yazdım ama olmadı.

 

[PLİNT]

verilerin geleceği sütun "C2" ("B" sütunu) doğru

"Cells(3, "A").Value ="
Sorduğunuz bu bölümse;
"c" sütununa almak için

Cells(b, "[COLOR="Red"]C[/COLOR]").Value =

"b" değişken (satır)

 

[soby53]

Soruyu yanlış sorduğumu şimdi farkettim. Ben sütunları değiştirmiştim onlara takılmayın.

Cells(b, "A").Value = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & dosya & "]Sayfa1'!R" & 3 & "C2")

Sabit bir satırı (B3) almam için sabitlemem gerekenin b deği c olması gerektiğini şimdi fark ettim. böylece sorun kalmadı. Çok teşekkür ederim.

 

[PLİNT]

Soruyu yanlış sorduğumu şimdi farkettim. Ben sütunları değiştirmiştim onlara takılmayın.

Cells(b, "A").Value = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & dosya & "]Sayfa1'!R" & 3 & "C2")
Sabit bir satırı (B3) almam için sabitlemem gerekenin b deği c olması gerektiğini şimdi fark ettim. böylece sorun kalmadı. Çok teşekkür ederim.

Merhaba
Kolay gelsin.
Gerçi siz çözmüşsüz ama yine de ilk mesajdaki kodlara dosya isimleri ilgili aşağıdaki gibi kod satırı ekledim.

[SIZE="2"]If a < 10 Then dosya = "0" & dosya[/SIZE]

 

[soby53]

İlginize çok Teşekkür ederim.

 

[şehiriçi]

sayın mucit 77 dünkü mesajımdan sonra şimdi fırsat bulup girdim ve çok kıymetli cevabınızı gördüm . makrolar hakkında bilgim yok denecek seviyede genellikle işlerimi fonksiyonlarla yapmaya çalışıyorum . makrolardan virüs bulaşır diye uzak duruyordum . çok teşekkür ederim
benim göndermiş olduğum dosya gibi yaklaşık 150 civarında dosyam var . dolayısıyla her bir dosyanın içinde bu kodu göstermeden ayrıca bir dosyada sadece diğer 150 dosyadaki ...görmek istediğim tarihe ait isim ve miktarı (kğ)
gösterebilirmisin
o zaman her dosyaya girip şu tarihte kim kaç yatırmış diye bakmak yerine
tek dosyada herhangi bir tarihte kimlerin total de ne kadar yatırdığını öğrenmiş olacağım .