Birden fazla dosyadan veri getirme

[Bora_Can]

Merhabalar,
Üç değişik veri dosyasındaki (Yavru_Data_1, 2 ve 3) verileri tek bir dosya içerisinde (Ana_Data) toplayacak bir makroya ihtiyacım var.
Toplanacak verilerin bir kısmı olduğu gibi gelecekken bir kısmında bazı işlemlerin (çarpma, bölme, birim değiştirme v.b.) yapılarak Ana_Data dosyasında ilgili sütuna yazılması gerekiyor. Bu arada Ana_Data dosyasında bazı sütunlara da hiç veri aktarılmayacak, onlar boş kalacak.

**Hangi sütuna nereden hangi verinin aktarılacağı Ana_Data dosyasında açıklamalı bir şekilde yazıyor.**

Dosyaların tamamının ilk sütunları birbirinin aynı, yani ilk sütunlar baz alınarak dosyalar birbirleriyle ilişkilendirilebilinir.
Ekteki dosyaları örnek olsun diye birkaç satır ve sütun olarak kısalttım, aslında gerçek veriler 50'yi aşkın sütun ve binlerce satırdan oluşuyor.
Bu makronun yazımı konusunda yardımcı olabilirseniz çok memnun olurum.

 

[dEdE]

Sayın Bora_Can,

Öncelikle Forumumuza hoş geldiniz.
Siz hiçbir çaba göstermeden tüm çalışmayı bize yaptırmak istiyorsunuz. Genellikle bu tür soruları yanıtlamam ama; "Yeni üyemiz için bir ayrıcalık yapalım ." dedim kendi kendime.
Ancak, saniyeyi saat:dakikaya çevirince artan saniyeleri yukarıyuvarlamayı yapamadım. Bunu da üstadlar halleder herhalde.
Dosyanız ilişiktedir.

Saygılar.

 

[Bora_Can]

Sayın dEdE,

Nazik yardımlarınız için çok teşekkür ederim. Üzerinde çalıştığım birleştirme işi vermiş olduğum örnekten çok daha detaylı ve "Nasıl yaparım?" sorusuna cevap olacak yapı taşlarını öğrenebilmek için konuyu açmıştım.

Yavru Data dosyalarındaki bilgilerin karışması ihtimaline karşı hali hazırda tüm dosyalarda aynı olan ilk sütun bilgilerinin karşılaştırılarak Ana Data dosyasına yazılması (İlk sütunların bir nevi index işlevi olması için) konusunda sizin yazmış olduğunuz programa IF...THEN komutuyla kendimce ilaveler yaptım ama olay doğru çalışıp çalışmadığını test etmeye gelince işler sarpa sardı.

Teorik olarak Ana Data dosyasında kırmızıyla işaretlediğim satıra gelince veri aktarmanın durması (o satırın boş kalması) ve bir sonraki satırdan devam etmesi gerekiyordu ama program hiçbirşey yokmuş gibi sonuna kadar devam etti. Ne kadar uğraştıysam da bir türlü sebebini bulamadım.

Kendi modifiye ettiğim haliyle dosyaları ekliyorum, zaman ayırıp da bir bakabilirseniz çok memnun olurum.

Çok teşekkürler ve iyi günler...

 

[dEdE]

Merhaba,
Sorunuzu/sorununuzu ilk mesajda tam olarak anlatsanız çözüm daha kolay olurdu.

Dosyaların tamamının ilk sütunları birbirinin aynı, yani ilk sütunlar baz alınarak dosyalar birbirleriyle ilişkilendirilebilinir

diyorsunuz ilk mesajda. Buna dayanarak tüm sütunu aktaran kod mantığı ile işlem yapılıyordu. Şimdiki isteğiniz kod mantığının tamamen değişmesini gerektiriyor. Bu defa hücreyi esas alan kod yazılması gerekiyor, yani herşey yeniden yapılacak. Yapılmayacak bir işlem değil ama bir kaç gün bakabileceğimi sanmıyorum.
Bu arada üstadlardan saniyeyi saat:dakikaya çevirince artan saniyeleri yukarıyuvarlama konusunda yardım beklediğimide belirtmek isterim.
Saygılarımla.

 

[dEdE]

Merhaba,
Kodu istediğiniz şekilde değiştirdim.
Bu arada saniyeyi saat:dakikaya çevirince artan saniyeleri yukarıyuvarlama konusunda yardımlarını esirgemeyen Sayın Levent Menteşoğlu'na teşekkür ediyorum.

Hoşçakalın.

Sub Aktar()
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & "\"

Set CObj = CreateObject("Excel.Application")
Set WBook1 = CObj.Workbooks.Open(Yol & "Yavru_Data_1.xlsx")
Set Wsheet1 = WBook1.Sheets("yavru_data_1")

Set WBook2 = CObj.Workbooks.Open(Yol & "Yavru_Data_2.xlsx")
Set Wsheet2 = WBook2.Sheets("yavru_data_2")

Set WBook3 = CObj.Workbooks.Open(Yol & "Yavru_Data_3.xlsx")
Set Wsheet3 = WBook3.Sheets("yavru_data_3")

Set Ana = Workbooks("Ana_Data.xlsm").Sheets("Sheet1")

Son = Ana.[A65536].End(3).Row

Columns("G:G").NumberFormat = "[h]:mm"
Columns("H:H").NumberFormat = "#,##0"
Columns("I:I").NumberFormat = "#,##0.00"

For i = 3 To Son
If Cells(i, 1).Font.ColorIndex = 3 Then GoTo Atla
    Cells(i, 2).Value = Wsheet1.Cells(i - 1, 2).Value
    Cells(i, 3).Value = Wsheet1.Cells(i - 1, 3).Value
    Cells(i, 6).Value = Wsheet1.Cells(i - 1, 4).Value
    Cells(i, 8).Value = Round(Wsheet1.Cells(i - 1, 5).Value / 33, 0)
    Cells(i, 9).Value = Wsheet1.Cells(i - 1, 6).Value * 2.2
    Cells(i, 5).Value = Wsheet2.Cells(i - 1, 2).Value
    
    SaniyeD = Wsheet3.Cells(i - 1, 2).Value / 86400
    Cells(i, 7).Value = TimeSerial(Hour(SaniyeD) + 24, Minute(SaniyeD) + 1, 0)
Atla:
Next

WBook1.Close 0
WBook2.Close 0
WBook3.Close 0

CObj.Quit

Application.ScreenUpdating = True
End Sub

 

[Bora_Can]

Üstadım,

Zahmetleriniz için çok teşekkür ederim, ancak bir konuda anlaşılan ben kendimi bir türlü ifade edememişim. Benim ihtiyacım olan makro önce Yavru_Data dosyalarının hepsinin ilk sütunlarıyla Ana_Data dosyasının ilk sütununu karşılaştıracak ve ilk sütundaki sayılar şayet birbirini tutuyorsa verileri kopyalamaya başlayacak.

Bu şartları kontrol edecek IF...Then...Else formüllerini kullanarak yollamış olduğunuz makroyu revize ettim ama nafile program bir türlü amaçladığım gibi çalışmadı.

Mümkünse aşağıdaki koda bakıp, IF...Then...Else formüllerinde nerede hata yaptığımı söyleyebilir misiniz?

Kıymetli zamanınız için tekrar tekrar teşekkürler...

Sub Aktar()
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & "\"

Set CObj = CreateObject("Excel.Application")
Set WBook1 = CObj.Workbooks.Open(Yol & "Yavru_Data_1.xlsx")
Set Wsheet1 = WBook1.Sheets("yavru_data_1")

Set WBook2 = CObj.Workbooks.Open(Yol & "Yavru_Data_2.xlsx")
Set Wsheet2 = WBook2.Sheets("yavru_data_2")

Set WBook3 = CObj.Workbooks.Open(Yol & "Yavru_Data_3.xlsx")
Set Wsheet3 = WBook3.Sheets("yavru_data_3")

Set Ana = Workbooks("Ana_Data.xlsm").Sheets("Sheet1")

Son = Ana.[A65536].End(3).Row

Columns("G:G").NumberFormat = "[h]:mm"
Columns("H:H").NumberFormat = "#,##0"
Columns("I:I").NumberFormat = "#,##0.00"

For i = 3 To Son

If Cells(i, 1).Value = Wsheet1.Cells(i - 1, 1).Value Then
DataMevcut1 = 1
Else: DataMevcut1 = 0
End If

If Cells(i, 1).Value = Wsheet2.Cells(i - 1, 1).Value Then
DataMevcut2 = 1
Else: DataMevcut2 = 0
End If

If Cells(i, 1).Value = Wsheet3.Cells(i - 1, 1).Value Then
DataMevcut3 = 1
Else: DataMevcut3 = 0
End If

DataMevcutAll = DataMevcut1 + DataMevcut2 + DataMevcut3

If DataMevcutAll = 3 Then
    Cells(i, 2).Value = Wsheet1.Cells(i - 1, 2).Value
    Cells(i, 3).Value = Wsheet1.Cells(i - 1, 3).Value
    Cells(i, 6).Value = Wsheet1.Cells(i - 1, 4).Value
    Cells(i, 8).Value = Round(Wsheet1.Cells(i - 1, 5).Value / 33, 0)
    Cells(i, 9).Value = Wsheet1.Cells(i - 1, 6).Value * 2.2
    SaniyeD = Wsheet3.Cells(i - 1, 2).Value / 86400
    Cells(i, 7).Value = TimeSerial(Hour(SaniyeD) + 24, Minute(SaniyeD) + 1, 0)
Else: GoTo Atla
End If
Atla:
Next i

WBook1.Close 0
WBook2.Close 0
WBook3.Close 0

CObj.Quit

Application.ScreenUpdating = True
End Sub