İsmi değişken excelden veri aktarma

yunusemre16 · 17 Ağu 2019

Merhaba,
Örnek olarak attığım excelde, alt taraflarda Film Adı, Kişi Sayısı ve Fiyat olarak yazılan yerler var. Bu yerlere elle Film adını kişi sayısını ve fiyatını yazıyorum. Büyükten küçüğe doğru.
Bu yazdığım raporu excel olarak alabiliyorum ama ismi her defasında değişik olarak geliyor.

Örnek olarak 2019_08_17 17_02_53-Film Hasılat Raporu
2019_08_17 17_02_50-Film Hasılat Raporu
2019_08_17 17_04_50-Film Hasılat Raporu
2019_08_15 14_04_50-Film Hasılat Raporu gibi.

Bunları şu şekilde kod ile Film Hasılat Raporu yazan excelleri seçebiliyorum.

Kod:

With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = "C:\BiletiniAl\Reports\*Film*Hasılat*Raporu*.xls"
        If .Show = -1 Then fileopen = .SelectedItems(1)
    End With

Soruma gelecek olursam, bu raporları elle yazmak yerine kişi sayısı en çokdan en aza doğru nasıl aktarabilirim.
Film Hasılat Raporunun örneğinide atıyorum örnek olarak. Yardımcı olursanız çok sevinirim. Şimdiden teşekkür ederim.

yunusemre16 · 18 Ağu 2019

Yardım edebilecek yok mu?

Feyzullah · 19 Ağu 2019

Eklemiş olduğunuz dosyanın manüel- elle hazırlanmış olanını da ekler misin?. Ney nere gelecek hiç bir şey anlaşılmıyor çünkü.

yunusemre16 · 19 Ağu 2019

Feyzullah' Alıntı:
Eklemiş olduğunuz dosyanın manüel- elle hazırlanmış olanını da ekler misin?. Ney nere gelecek hiç bir şey anlaşılmıyor çünkü.

Merhaba. Yarım saat içinde elle yapılmış şekilde hemen atıyorum tekrar dosyayı. İlginiz için çok teşekkür ederim

Feyzullah · 19 Ağu 2019

Tamam Hocam, Acele etmenize gerek yok. Buralardayım.

yunusemre16 · 19 Ağu 2019

Feyzullah' Alıntı:
Tamam Hocam, Acele etmenize gerek yok. Buralardayım.

Tekrardan merhaba,

Elle doldurduğum yeri renkli olarak gösterdim, biraz aşağıda kalıyor, ismi değişken olan exceldeki bilgileri Örnek Kasa exceline aktarmak istiyorum, bunu yaparkende Hızlı ve Öfkeli yazanları tek olarak almak istiyorum, raporlama yaparken o şekilde alamıyorum malesef,(Bu raporlama sürekli değiştiği için Hızlı ve Öfkeli yerine başka filmlerde yazabiliyor, .......... 3D / Türkçe Altyazılı , .......... 3D / Türkçe Dublaj , ......... Türkçe Dublaj , .................. Türkçe Altyazılı gibi seçenekler olabiliyor. Hızlı ve Öfkeli filmini örnek olarak göstermek istedim)

Hızlı ve Öfkeli: Hobbs ve Shaw 3D / Türkçe Altyazılı

Hızlı ve Öfkeli: Hobbs ve Shaw 3D / Türkçe Dublaj

Hızlı ve Öfkeli: Hobbs ve Shaw Türkçe Dublaj

Bu şekilde ayrı ayrı çıkıyor isimleri,
Ama ben bunları sadece
Hızlı ve Öfkeli: Hobbs ve Shaw olarak yazıp adetlerini ve fiyatlarını toplayıp yazdırmak istiyorum. Adet ve fiyat olarak en yüksekleri sıralandırıp adetlerini ve fiyatlarını yazdırmak istiyorum elle doldurduğum exceldeki gibi. Biraz karmaşık ve uğraş verici birşey olduğunu düşünüyorum. Ama bu konuda yardımcı olabilirseniz çok sevinirim.

Feyzullah · 19 Ağu 2019

VBA:

Sub exceldestek_ADO()
'^^DOSYA YOLU
dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
''^^
Range("J121:N133").ClearContents
''www.exceldepo.com metehan8001****
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dsy & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select [Film Adı], [Adet], [Fiyat] from [Sheet$f5:m] Where [Film Adı] Is Not Null"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
sat = 121
            Do While Not rs.EOF
dizi = Array(" 3D / Türkçe Dublaj", " 3D / Türkçe Altyazılı", " Altyazılı", " 3D /", " Türkçe Dublaj")
adi = rs(0).Value
For s = LBound(dizi) To UBound(dizi)
adi = Replace(adi, dizi(s), "")
Next s

kontrol = False
For Each Rng In Range("J121:J133")
If Rng.Value = adi Then
Rng.Offset(0, 1) = Rng.Offset(0, 1) + rs(1).Value
Rng.Offset(0, 2) = Rng.Offset(0, 2) + rs(2).Value
kontrol = True
Exit For
End If
Next Rng

If kontrol <> True Then
Cells(sat, "J") = adi
Cells(sat, "M") = rs(1).Value
Cells(sat, "N") = rs(2).Value
sat = sat + 1
End If
            rs.movenext
            Loop
End If
rs.Close: con.Close

'''''''''^^SIRLAMA
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
sayfa = ActiveSheet.Name
sorgu = "Select *  From [" & sayfa & "$J121:N133] Where f1 Is Not Null order by f4 desc"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
'MsgBox rs(0).Value
''Range("J121:N133").ClearContents
Range("J121").CopyFromRecordset rs
End If
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing

MsgBox "...:İşlem Tamam:...", vbInformation + vbMsgBoxRtlReading, "ExcelDestek.Com"
End Sub

yunusemre16 · 19 Ağu 2019

Feyzullah' Alıntı:

VBA:

Sub exceldestek_ADO()
'^^DOSYA YOLU
dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
''^^
Range("J121:N133").ClearContents
''www.exceldepo.com metehan8001****
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dsy & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select [Film Adı], [Adet], [Fiyat] from [Sheet$f5:m] Where [Film Adı] Is Not Null"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
sat = 121
            Do While Not rs.EOF
dizi = Array(" 3D / Türkçe Dublaj", " 3D / Türkçe Altyazılı", " Altyazılı", " 3D /", " Türkçe Dublaj")
adi = rs(0).Value
For s = LBound(dizi) To UBound(dizi)
adi = Replace(adi, dizi(s), "")
Next s

kontrol = False
For Each Rng In Range("J121:J133")
If Rng.Value = adi Then
Rng.Offset(0, 1) = Rng.Offset(0, 1) + rs(1).Value
Rng.Offset(0, 2) = Rng.Offset(0, 2) + rs(2).Value
kontrol = True
Exit For
End If
Next Rng

If kontrol <> True Then
Cells(sat, "J") = adi
Cells(sat, "M") = rs(1).Value
Cells(sat, "N") = rs(2).Value
sat = sat + 1
End If
            rs.movenext
            Loop
End If
rs.Close: con.Close

'''''''''^^SIRLAMA
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
sayfa = ActiveSheet.Name
sorgu = "Select *  From [" & sayfa & "$J121:N133] Where f1 Is Not Null order by f4 desc"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
'MsgBox rs(0).Value
''Range("J121:N133").ClearContents
Range("J121").CopyFromRecordset rs
End If
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing

MsgBox "...:İşlem Tamam:...", vbInformation + vbMsgBoxRtlReading, "ExcelDestek.Com"
End Sub

Hocam size ne kadar teşekkür etsem azdır. Elinize emeğinize sağlık, çok ama çok teşekkür ederim. Cidden çok büyük bir bilgi verdiniz bana. Tekrardan çok ama çok teşekkür ederim

yunusemre16 · 19 Ağu 2019

Feyzullah' Alıntı:

VBA:

Sub exceldestek_ADO()
'^^DOSYA YOLU
dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
''^^
Range("J121:N133").ClearContents
''www.exceldepo.com metehan8001****
Set con = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
dsy & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select [Film Adı], [Adet], [Fiyat] from [Sheet$f5:m] Where [Film Adı] Is Not Null"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
sat = 121
            Do While Not rs.EOF
dizi = Array(" 3D / Türkçe Dublaj", " 3D / Türkçe Altyazılı", " Altyazılı", " 3D /", " Türkçe Dublaj")
adi = rs(0).Value
For s = LBound(dizi) To UBound(dizi)
adi = Replace(adi, dizi(s), "")
Next s

kontrol = False
For Each Rng In Range("J121:J133")
If Rng.Value = adi Then
Rng.Offset(0, 1) = Rng.Offset(0, 1) + rs(1).Value
Rng.Offset(0, 2) = Rng.Offset(0, 2) + rs(2).Value
kontrol = True
Exit For
End If
Next Rng

If kontrol <> True Then
Cells(sat, "J") = adi
Cells(sat, "M") = rs(1).Value
Cells(sat, "N") = rs(2).Value
sat = sat + 1
End If
            rs.movenext
            Loop
End If
rs.Close: con.Close

'''''''''^^SIRLAMA
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
sayfa = ActiveSheet.Name
sorgu = "Select *  From [" & sayfa & "$J121:N133] Where f1 Is Not Null order by f4 desc"
rs.Open sorgu, con, 1, 1
If rs.RecordCount > 0 Then
'MsgBox rs(0).Value
''Range("J121:N133").ClearContents
Range("J121").CopyFromRecordset rs
End If
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing

MsgBox "...:İşlem Tamam:...", vbInformation + vbMsgBoxRtlReading, "ExcelDestek.Com"
End Sub

Hocam ben birşey daha sormak istiyorum size,

Sizin kullandığınız

Kod:

'^^DOSYA YOLU

dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")

''^^

kod ile

Kod:

   With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = "C:\BiletiniAl\Reports\*Film*Hasılat*Raporu*.xls"
        If .Show = -1 Then fileopen = .SelectedItems(1)
    End With

Bu kodu bağdaşlaştırabilirmiyiz, yani direk C:\BiletiniAl\Reports\Film Hasılat Raporu.xls dosyalarını filtrelemiş olurum

Feyzullah · 19 Ağu 2019

Kod:

'^^DOSYA YOLU
dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
''^^

Yukarıdaki kodu aşağıdaki gibi değiştirin.

VBA:

'^^DOSYA YOLU
   With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = "C:\BiletiniAl\Reports\*Film*Hasılat*Raporu*.xls"
        If .Show = -1 Then dsy = .SelectedItems(1)
    End With
    If dsy = "" Then MsgBox "Dosya Seçmediniz....": Exit Sub
''^^

Feyzullah · 19 Ağu 2019

Feyzullah' Alıntı:

Kod:

'^^DOSYA YOLU
dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
''^^

Yukarıdaki kodu aşağıdaki gibi değiştirin.

VBA:

'^^DOSYA YOLU
dsy = "C:\BiletiniAl\Reports\*Film*Hasılat*Raporu*.xls"
If Dir(dsy) = "" Then
dsy = Application.GetOpenFilename(FileFilter:="Excel Dosyaları,*.xls;*.xlsx;*.xlsb;*.xlsm;*.csv", Title:="Dosya Seç")
If dsy = False Then MsgBox "Dosya seçmediniz": Exit Sub
End If

Ben son mesajınızı yanlış anlamışım. Doğru kodu müsait olduğumda paylaşırım.

yunusemre16 · 19 Ağu 2019

Feyzullah' Alıntı:
Ben son mesajınızı yanlış anlamışım. Doğru kodu müsait olduğumda paylaşırım.

Tamamdır Hocam, zahmet veriyorum size, çok teşekkür ederim tekrardan

Feyzullah · 19 Ağu 2019

10 nolu mesajı düzenledim onu kullanabilirsiniz.

yunusemre16 · 19 Ağu 2019

Feyzullah' Alıntı:
10 nolu mesajı düzenledim onu kullanabilirsiniz.

Tekrardan size binlerce kez teşekkür ederim. Elinize emeğinize sağlık, diğer sitelerde daha çok aktif kullanıcı olmasına ragmen, malesef bu soruma cevap bulamamıştım. Siz emek verip ilgi gösterdiniz. Allah razı olsun

Feyzullah · 19 Ağu 2019

EyvAllah, iyi çalışmalar.

	İsmi Değişken Excel Dosyasında Veri Çekme yunusemre16 10 May 2024 Makro Soruları
	Hücrede Değişken Verileri Toplama cakarem 27 Eyl 2024 Makro Soruları
	Değişken İsimli Excel Kitabından Veri Çekme Feyzullah 7 Mar 2024 Makro Soruları
	Excelden Whatsappa Veri Yollama excelismail 6 Eyl 2020 Makro Soruları
	Excelden Outlook Takvime Veri Aktarma akdolunay 28 Şub 2021 Makro Soruları