Soru Kapalı Dosyadan Veri Aktarımı Hakkında2..

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
942
Excel Vers. ve Dili
Excel 2016,32bit
Merhabalar;

Öncelikle daha önce burada benzer bir konu açmış ve Sayın Zeki Gürsoy'un yardımı ile sonuca ulaşmıştım.Gayet başarılı şekilde devam ederken verilerim ve parametrelerim çoğaldıkça yeni düzenlemelere ihtiyacım olduğumdan tekrar benzer bir konu açmak durumunda kaldım:-(
Daha önce açmış olduğum konu başlığını "çözüldü" olarak değiştirdiğim için revize edemedim. O yüzden yeni bir konu başlığı açma ihtiyacı duydum. Benzer bir konunun tekrar açılmaması gerekirdi o yüzden forum yöneticilerinden bu konuda özür dilerim.:(

Sorunuma gelecek olur isem şöyle ki;
"açık" ve "kapalı" olmak üzere iki adet çalışma dosyam mevcut.

"kapalı" dosyadaki "ham veriler" sayfasında ; 4.satırda bulunan , "E:H:K:N:Q:T:W:Z:AC:AF:AI:AL" sütunlarındaki verileri,

"açık" dosyadaki "sonuçlar" sayfasındaki ; "D" sütununa aktarmak istiyorum. ("D4" ten itibaren olacak)


Not:
* "kapalı" dosyadaki "ham veriler" sayfasında bulunan veriler de formül olacak aktarılırken sorun yaratmaması adına bilgilendirmek isterim.
** "kapalı" dosyadaki "ham veriler" sayfasında 4.satırdan 250.satıra kadar veriler bulunmakta, haliyle işlemler aynı mantık ile tüm verileri aktarmalı.
 

Ekli dosyalar

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,104
Excel Vers. ve Dili
office2010
Merhaba,

Açık ve Kapalı dosyalar aynı klasörde olmalı.

Kod:
Sub test()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "kapalı.xlsx"
GetObject (yol & dosya)
Set d = CreateObject("scripting.dictionary")
sayfa = "HAM VERİLER"
Set s1 = Workbooks(dosya).Worksheets(sayfa)
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("B2:AL" & son).Value
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
    For i = 3 To UBound(a)
        For j = 3 To UBound(a, 2)
        If a(1, j) <> "" Then
            krt = a(i, 1) & "|" & a(i, 2) & "|" & a(1, j)
            d(krt) = a(i, j + 1)
        End If
        Next j
    Next i
Set sc = Sheets("sonuclar")
son = sc.Cells(Rows.Count, 2).End(3).Row
b = sc.Range("B3:J" & son).Value
sat = UBound(b)
sut = UBound(b, 2)
ReDim c(1 To sat - 1, 1 To sut - 2)
    For i = 2 To sat
        For j = 3 To sut
            krt = b(i, 1) & "|" & b(1, j) & "|" & b(i, 2)
            c(i - 1, j - 2) = d(krt)
        Next j
    Next i
sc.[D4].Resize(sat - 1, sut - 2) = c
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub
 

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
942
Excel Vers. ve Dili
Excel 2016,32bit
Sayın Ziynettin, ilginize çok teşekkür ederim. Ellerinize sağlık, tam istediğim şekilde oldu.(y):giggle:
 

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
942
Excel Vers. ve Dili
Excel 2016,32bit
Merhabalar,
1 nolu mesajımda belirttiğim soruma sayın Ziynettin 2 nolu mesajıyla çok güzel çözüm getirdi ve sorunsuz kullanmaktayım. Lakin 1 nolu mesajımda bulunan;
"kapalı" dosyadaki "ham veriler" sayfasında ; 4.satırda bulunan , "E:H:K:N:Q:T:W:Z:AC:AF:AI:AL" sütunlarındaki verilerin yerine ,

Şu verileri almak istemekteyim ;

"kapalı" dosyadaki "ham veriler" sayfasında ; 4.satırda bulunan , "F:I:L:O:R:U:X:AA:AD:AG:AJ:AM" sütunlarındaki verilerin , yine aynı şekilde

"açık" dosyadaki "sonuçlar" sayfasındaki ; "D" sütununa aktarmak istiyorum. ("D4" ten itibaren olacak)

Sayın Ziynettin'in 2 nolu mesajındaki kodlarda yapmaya çalıştım ama yapamadım. :-( Kodlar üzerinde nasıl bir değişiklik ile yapılabilir?

Ekte "kapalı" dosyadaki kırmızı renkli verileri almamda sıkıntı olmuyor hali hazırdaki kodlar ile, lakin sarı renkli sütunlardaki verileri aynı şekilde almak istiyorum.:giggle:
 

Ekli dosyalar

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,104
Excel Vers. ve Dili
office2010
Kod:
Sub test1()
Z = TimeValue(Now)
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "kapalı.xlsx"
GetObject (yol & dosya)
Set d = CreateObject("scripting.dictionary")
sayfa = "HAM VERİLER"
Set s1 = Workbooks(dosya).Worksheets(sayfa)
son = s1.Cells(Rows.Count, 2).End(3).Row
a = s1.Range("B2:AM" & son).Value
sutun = Array("", 3, 6, 9, 12, 15, 18, 21, 24, 27, 30, 33, 36)
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
    For i = 3 To UBound(a)
        For j = 1 To UBound(sutun)
            krt = a(i, 1) & "|" & a(i, 2) & "|" & a(1, sutun(j))
            d(krt) = a(i, sutun(j) + 2)
        Next j
    Next i
Set sc = Sheets("sonuclar")
son = sc.Cells(Rows.Count, 2).End(3).Row
b = sc.Range("B3:J" & son).Value
sat = UBound(b)
sut = UBound(b, 2)
ReDim c(1 To sat - 1, 1 To sut - 2)
    For i = 2 To sat
        For j = 3 To sut
            krt = b(i, 1) & "|" & b(1, j) & "|" & b(i, 2)
            c(i - 1, j - 2) = d(krt)
        Next j
    Next i
sc.[D4].Resize(sat - 1, sut - 2) = c
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub
 

yesimgurol

Altın Üye
Katılım
8 Aralık 2011
Mesajlar
942
Excel Vers. ve Dili
Excel 2016,32bit
Sayın Ziynettin, ilginize çok teşekkür ederim.Ellerinize sağlık istediğim şekilde oldu.(y):giggle::giggle:
 
Üst