• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Inputbox ile alınan dosyadan veri alma

Q

qwert11

Katılım
26 Şubat 2008
Mesajlar
52
Excel Vers. ve Dili
2003-2000
Merhaba arkadaşlar şöyle bir sorum olacak
inputbox ile aldığım bir excel dosyasından verileri çektiğim dosyanın bir çalışma sayfasına aktarıcam bunun için nasıl bir kod yazılmalı.dosya eklemiyorum öyle bir dosya mevcut değil. Kodlar çok esnek ve basit olmalı yardımcı olacak arkadaşlar kodu yazdıklarında benim yazmam gereken yerleri belirtirlerse sevinirim
 
nasıl yardımcı olmamızı istiyorsunuz dosya yok veri yok hangi veriler alınacak bilgi yok.
sanırım biz kahiniz senin aklından geçenleri biliyoruz dur bu şunu istiyor hemen kod yazıp göndereyim öyle mi_?
 
ihsan bey bu kadar kızacak birşey yok.helede tiiye almaya hiç gerek yok böyle birşeyin mümkün olmadığını söylemeniz yeterli.ayrıca genel bir yapıdan bahsediyorum nasıl bir yol izleniliyor dosya adı sürekli değişiyor değiştiği içinde sabitleyemiyoruz dosyayı öyle olsa zaten doluca örnek var bu formda .alınan bilgilerin adresleri sabit sadece dosyanın ismi değişiyor dün a.xls olan dosya bugün b.xls oluyor
 
qwert11' Alıntı:
ihsan bey bu kadar kızacak birşey yok.helede tiiye almaya hiç gerek yok böyle birşeyin mümkün olmadığını söylemeniz yeterli.ayrıca genel bir yapıdan bahsediyorum nasıl bir yol izleniliyor dosya adı sürekli değişiyor değiştiği içinde sabitleyemiyoruz dosyayı öyle olsa zaten doluca örnek var bu formda .alınan bilgilerin adresleri sabit sadece dosyanın ismi değişiyor dün a.xls olan dosya bugün b.xls oluyor
Genişletmek için tıkla ...

kızdığımı düşünüyorsunuz ama yanılıyorsunuz ben size yol göstermeye çalışıyorum bir dosya ekleseniz ve şöyle bir şey istiyorum imkanı var mı deseniz daha iyi olmaz mıydı.
inputbox'a bir örnek
Kod: 
Option Explicit
Sub dene()
Dim ts
ts = InputBox("Kitap Adı Giriniz", "Kitap Adı Girişi")
If ts = "" Then Exit Sub
MsgBox ts
End Sub
yazdığınızı mesaj olarak gösterir
 
ihsan bey dosyamın büyüklüğü 32 mb (içinizden yuh diye geçiriğinizi hissedebiliyorum)
size hali hazırdaki makronun bizim için önemli kısnımı yazıyorum
Dim dosya__ As Variant
Dim i As Long
Dim stok(300)
Dim D As String
Dim termin(30): Dim miktar(30)
tarih = Cells(1, 1)
n = 1
dosya__ = Application.GetOpenFilename _
(FileFilter:="Excel Filer (*.xls),*.xls", _
Title:="Open File(s)", MultiSelect:=True)

If Not IsArray(dosya__) Then Exit Sub

With Application
.ScreenUpdating = False
For i = 1 To UBound(dosya__)
Workbooks.Open dosya__(i)
Next i
.ScreenUpdating = True
End With




'------------------- dosya DOSYASINDAN VERİLERİ AL-------------------

Workbooks.Open Filename:= 'dosyanın adresinide bu kısma yazıyordum
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Do
Windows("270111.xls").Activate ' dosyanın ismini bu kısma yazıyordum

Sheets(n).Select
Set skod1 = Cells(5, 1)
skod2 = Right(skod1, 22): skod = Left(skod2, 11)
Set tes1 = Cells(5, 3)
tes2 = Right(tes1, 5): tes = Left(tes2, 3)
sontestar = Cells(16, 1)
sonirs = Cells(16, 2)
sonadet = Cells(16, 3)
acil = Cells(13, 5)
bakiye = Cells(13, 4)


satır = Cells(21, 1)
If satır <> "Keine Eintragungen vorhanden !" And satır <> "" Then
s = 0
Do

termin(s) = CDate(Cells(21 + s, 1))
miktar(s) = Cells(21 + s, 2)
s = s + 1
' Loop Until Cells(21 + s, 4) <> ""
Loop Until Cells(21 + s, 1) = ""
Windows("Kopya 2011 06 SATIS TERMİN.XLS").Activate
Sheets("dosya").Select
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
Cells(3 + mn, 3).Select: ActiveCell.FormulaR1C1 = tes
Cells(3 + mn, 4).Select: ActiveCell.FormulaR1C1 = sontestar
Cells(3 + mn, 5).Select: ActiveCell.FormulaR1C1 = sonirs
Cells(3 + mn, 6).Select: ActiveCell.FormulaR1C1 = sonadet
Cells(3 + mn, 9).Select: ActiveCell.FormulaR1C1 = bakiye
Cells(3 + mn, 10).Select: ActiveCell.FormulaR1C1 = acil
For j = 0 To s - 1
Cells(3 + mn, 7).Select: ActiveCell.FormulaR1C1 = termin(j)
Cells(3 + mn, 8).Select: ActiveCell.FormulaR1C1 = miktar(j)
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
termin(j) = "": miktar(j) = ""
mn = mn + 1
Next j
n = n + 1: s = 0
Else
n = n + 1: s = 0
End If
Loop Until n = 31
End Sub
bu makroda firma bana bir excel gönderiyor bende onun önceden ismini makroya girip yazıyordum sonra çalıştırıyordum şimdi bunu bir input box veya dosya seçerek yapmaya çalışıyorum makrodan dilerim demek istediğimi anlarsınız
 
qwert11' Alıntı:
ihsan bey dosyamın büyüklüğü 32 mb (içinizden yuh diye geçiriğinizi hissedebiliyorum)
size hali hazırdaki makronun bizim için önemli kısnımı yazıyorum
Dim dosya__ As Variant
Dim i As Long
Dim stok(300)
Dim D As String
Dim termin(30): Dim miktar(30)
tarih = Cells(1, 1)
n = 1
dosya__ = Application.GetOpenFilename _
(FileFilter:="Excel Filer (*.xls),*.xls", _
Title:="Open File(s)", MultiSelect:=True)

If Not IsArray(dosya__) Then Exit Sub

With Application
.ScreenUpdating = False
For i = 1 To UBound(dosya__)
Workbooks.Open dosya__(i)
Next i
.ScreenUpdating = True
End With




'------------------- dosya DOSYASINDAN VERİLERİ AL-------------------

Workbooks.Open Filename:= 'dosyanın adresinide bu kısma yazıyordum
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Do
Windows("270111.xls").Activate ' dosyanın ismini bu kısma yazıyordum

Sheets(n).Select
Set skod1 = Cells(5, 1)
skod2 = Right(skod1, 22): skod = Left(skod2, 11)
Set tes1 = Cells(5, 3)
tes2 = Right(tes1, 5): tes = Left(tes2, 3)
sontestar = Cells(16, 1)
sonirs = Cells(16, 2)
sonadet = Cells(16, 3)
acil = Cells(13, 5)
bakiye = Cells(13, 4)


satır = Cells(21, 1)
If satır <> "Keine Eintragungen vorhanden !" And satır <> "" Then
s = 0
Do

termin(s) = CDate(Cells(21 + s, 1))
miktar(s) = Cells(21 + s, 2)
s = s + 1
' Loop Until Cells(21 + s, 4) <> ""
Loop Until Cells(21 + s, 1) = ""
Windows("Kopya 2011 06 SATIS TERMİN.XLS").Activate
Sheets("dosya").Select
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
Cells(3 + mn, 3).Select: ActiveCell.FormulaR1C1 = tes
Cells(3 + mn, 4).Select: ActiveCell.FormulaR1C1 = sontestar
Cells(3 + mn, 5).Select: ActiveCell.FormulaR1C1 = sonirs
Cells(3 + mn, 6).Select: ActiveCell.FormulaR1C1 = sonadet
Cells(3 + mn, 9).Select: ActiveCell.FormulaR1C1 = bakiye
Cells(3 + mn, 10).Select: ActiveCell.FormulaR1C1 = acil
For j = 0 To s - 1
Cells(3 + mn, 7).Select: ActiveCell.FormulaR1C1 = termin(j)
Cells(3 + mn, 8).Select: ActiveCell.FormulaR1C1 = miktar(j)
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
termin(j) = "": miktar(j) = ""
mn = mn + 1
Next j
n = n + 1: s = 0
Else
n = n + 1: s = 0
End If
Loop Until n = 31
End Sub
bu makroda firma bana bir excel gönderiyor bende onun önceden ismini makroya girip yazıyordum sonra çalıştırıyordum şimdi bunu bir input box veya dosya seçerek yapmaya çalışıyorum makrodan dilerim demek istediğimi anlarsınız
Genişletmek için tıkla ...

makronuzda kırmızı boyadığım yere mi adı yazıyorsunuz
 
EVET İHSAN BEY
Workbooks.Open Filename:= 'dosyanın adresinide bu kısma
Windows("270111.xls").Activate KISMININ İÇİ SÜREKLİ DEĞİŞİYOR
 
qwert11' Alıntı:
EVET İHSAN BEY
Workbooks.Open Filename:= 'dosyanın adresinide bu kısma
Windows("270111.xls").Activate KISMININ İÇİ SÜREKLİ DEĞİŞİYOR
Genişletmek için tıkla ...

merhaba
bu kodu ayarlıyabilirsiniz sanırım
Kod: 
Option Explicit
Sub dosya_adı()
Dim ts
ts = InputBox("Dosya Adı Giriniz", "Dosya Adı Girişi")
If ts = "" Then Exit Sub
Workbooks.Open Filename:=("[COLOR="Red"]D:\[/COLOR]" & ts) & ".xlsx"
End Sub
kırmızoya boyadığım yere yol bilgisi yazın. bir klasör adı ile yapacaksanız sonuna mutlaka \ ( slash ) işaretini koyunuz.
örneğin
D sürücüsünde aa adlı klasör olsun
"D:\aaaa\"
Genişletmek için tıkla ...
şekline yazın
 
makroya aşağıda kırmızı ile belirtilen kısmı ekleyince aşıda ikinci kırmızı belirttiğim noktada hata almaktayım


Dim fn
fn = Application.GetOpenFilename

Dim stok(300)
Dim D As String
Dim termin(30): Dim miktar(30)
tarih = Cells(1, 1)
n = 1



'------------------- dosya DOSYASINDAN VERİLERİ AL-------------------

Workbooks.Open Filename:=fn
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Do
' Windows(fn & ".XLS").Activate
' Windows(fn).Activate

Sheets(n).Select
Set skod1 = Cells(5, 1)
skod2 = Right(skod1, 22): skod = Left(skod2, 11)
Set tes1 = Cells(5, 3)
tes2 = Right(tes1, 5): tes = Left(tes2, 3)
sontestar = Cells(16, 1)
sonirs = Cells(16, 2)
sonadet = Cells(16, 3)
acil = Cells(13, 5)
bakiye = Cells(13, 4)


satır = Cells(21, 1)
If satır <> "Keine Eintragungen vorhanden !" And satır <> "" Then
s = 0
Do

termin(s) = CDate(Cells(21 + s, 1)) '2. kez döndüğünde döngüde type mistach hatası almaktayım
miktar(s) = Cells(21 + s, 2)
s = s + 1
' Loop Until Cells(21 + s, 4) <> ""
Loop Until Cells(21 + s, 1) = ""

Windows("Kopya 2011 06 SATIS TERMİN.XLS").Activate
Sheets("dosya").Select
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
Cells(3 + mn, 3).Select: ActiveCell.FormulaR1C1 = tes
Cells(3 + mn, 4).Select: ActiveCell.FormulaR1C1 = sontestar
Cells(3 + mn, 5).Select: ActiveCell.FormulaR1C1 = sonirs
Cells(3 + mn, 6).Select: ActiveCell.FormulaR1C1 = sonadet
Cells(3 + mn, 9).Select: ActiveCell.FormulaR1C1 = bakiye
Cells(3 + mn, 10).Select: ActiveCell.FormulaR1C1 = acil
For j = 0 To s - 1
Cells(3 + mn, 7).Select: ActiveCell.FormulaR1C1 = termin(j)
Cells(3 + mn, 8).Select: ActiveCell.FormulaR1C1 = miktar(j)
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
termin(j) = "": miktar(j) = ""
mn = mn + 1
Next j
n = n + 1 ': s = 0
Else
n = n + 1 ': s = 0
End If
Loop Until n = 31









cevabınız için teşekkürler lakin tam olarak beklediğim değil .bana dosya mail olarak gelmekte bende dosyayı dizinde bir yere kaydediyorum ardından kayıt ettiğim dizini yukarda
Workbooks.Open Filename:= belirtilen yerin karşısına yazıyorum ardından dosyanın isminide yukarda bir önceki yazımda belirttiğim yere yazıyorum .şimdi uğraştığım şey şu
bu yazmalar ile uğraşmadan bir upload (veya dosya seçme penceresinden )penceresinden kaydedilen dosyayı seçip makroyu çalıştırmak
 
Son düzenleme:
sorunuzu biraz daha açar mısınız tam olarak ne yapmak istiyorsunuz.
mail ile dosya geliyor siz bir yere kayıt yapıyorsunuz sonra bu dosyayı açmak istiyorsunuz diye anladım ben.
 
elimde terminleme dosyası mevcut.müşterim herbir parçanın ayrı shettlerde olduğu bir excel göndermekte bana .gönderdiği dosyayı bilgisayarımda herhangi bir yere kayıt ediyorum.Ardından kayıt ettiğim dosyanın adresini ve ismini bendeki terminleme dosyasındaki makronun belirttiğim yerlerine yazıyorum ve makroyu çalıştırıyorum.
dilerim bu noktaya kadar ne yaptığımı anlamışssınızdır
şimdi yapmak istediğim şey ise şu:
indirdiğimiz bu dosyayı hiç makroların içine yazmadan kapalı dosyadan veri alır gibi seçip makroyu çalıştırmak istemekteyiz.hiç bir şekilde makroların içine birşey yazılmasın istiyoruz.bunun yerine bir seçim ekranı gelsin ve bu seçim ekranı ile email ile gelmiş olan dosyayı alsın ve makro çalışsın

dilerim anlatabilmişimdir
 
şimdi anladığım kadarı ile ben anlatayım.
siz dosyayı aldınız kaydettiniz buraya kadar tamam.
bu dosyadan ne tarz veriler alınacak.
eğer ki bu belge hiç açılmayacak ise konu yanlış oldu siz şöyle bir konu açmalısınız. ben mail ile aldığım dosyayı hiç açmadan bir İnputbox yardımı ile dosyanın içindeki bilgileri kendi excel dosyama almak istiyorum tarzı bir şey olmalı.
yok ben dosyayı açsamda olur içindeki bilgileri alayım ama hiç değişiklik yapmıyayım derseniz o zaman şöyle bir yok gösterebilirim size.
2 tane dosya oluşturun 1 verilerin olduğu dosya 2 verilerin alınacağı dosya
bu iki dosyayı karambol veriler ile doldurun ve şunu istiyorum deyin. o zaman yardımcı olabilirim.
bir de verilerin olduğu dosyanın yol'unu yazarsanız daha iyi olur
 
şimdi size 2 dosya gönderiyorum (madem ekleyebiliyordunda neden eklemedin diye sormayın bayağı kırptım zira)
bu dosyalardan biri bana mail ile gelen ve ismi 270111.xls olan dosya diğeride benim terminleme dosyam
terminleme dosyasında ki makroy yukardakiler ile değiştirdiğinizde demek istediğimi nereye varmak istediği daha iyi anlatmış olurum
şimdiden zahmetleriniz ve yardımlarınız için teşekkürler
 

Ekli dosyalar

bu makro normal şartlarda çalışıyor yanlış mıyım_?
doğru ise
şimdi siz benden tam olarak ne istiyorsunuz.
bu kitap'ın adını inputbox'a gireceksiniz sanırım.
yoksa tüm adresi mi gireceksiniz bunu anlayamadım
 
Makro çalışıyor .fakat ben dosya yolunu ve dosya adını içine yazmaktansa dosyayı seçip verilerin aktarılmasını istemekteyim.yoksa her hafta (bazen bir kaç günde bir) vba yı açıp indiridğim dosyanın konumunu ve adını girecem .istediğim terminleme butınuna basınca hangi dosyadan veri alacağımı sorsun ve sayfayı güncellesin verileri alsın)
 
qwert11' Alıntı:
Makro çalışıyor .fakat ben dosya yolunu ve dosya adını içine yazmaktansa dosyayı seçip verilerin aktarılmasını istemekteyim.yoksa her hafta (bazen bir kaç günde bir) vba yı açıp indiridğim dosyanın konumunu ve adını girecem .istediğim terminleme butınuna basınca hangi dosyadan veri alacağımı sorsun ve sayfayı güncellesin verileri alsın)
Genişletmek için tıkla ...

ben şimdi yolu İnputbox'a bağlıyacağım ama bu adres konusunda bazı şüphem var. şüphem şu bu adresi devamlı aklınızda nasıl tutacaksınız. bu böyle mantıklı olur mu_?
yoksa şöyle bir şey yapsak olur mu_? bir hücreye yazsak yolu ve yola oradan başvursa ve verileri alıp makro çalışsa yol değiştiğinde hücredeki yol'u silseniz ve ona göre tekrardan yol'u yazarak makroyu çalıştırsanız. Not : Bu hücreye yazılacak olan yolu İnputbok ile ben yazdırayım. hatta hücredeki adresi'de ben sildireyim makroya tabi dilerseniz anlatabildim mi_?
benim maksadım sorun çıkartmak ve sorunuzu çözmemek değil daimi bir şey yapmak ve devamlı kullanabileceğiz bir şekilde çözüm sunmak
 
İhsan Tank' Alıntı:
ben şimdi yolu İnputbox'a bağlıyacağım ama bu adres konusunda bazı şüphem var. şüphem şu bu adresi devamlı aklınızda nasıl tutacaksınız. bu böyle mantıklı olur mu_?
yoksa şöyle bir şey yapsak olur mu_? bir hücreye yazsak yolu ve yola oradan başvursa ve verileri alıp makro çalışsa yol değiştiğinde hücredeki yol'u silseniz ve ona göre tekrardan yol'u yazarak makroyu çalıştırsanız. Not : Bu hücreye yazılacak olan yolu İnputbok ile ben yazdırayım. hatta hücredeki adresi'de ben sildireyim makroya tabi dilerseniz anlatabildim mi_?
benim maksadım sorun çıkartmak ve sorunuzu çözmemek değil daimi bir şey yapmak ve devamlı kullanabileceğiz bir şekilde çözüm sunmak
Genişletmek için tıkla ...

işte akıl akıldan üstündür bunu hiç düşünmemiştim tabii bence güzel bir çözüm ellerinize sağlık
 
qwert11' Alıntı:
işte akıl akıldan üstündür bunu hiç düşünmemiştim tabii bence güzel bir çözüm ellerinize sağlık
Genişletmek için tıkla ...

merhaba
module'deki kodu bununla değiştirerek dener misiniz
Kod: 
Sub maillegelen()
Dim stok(300)
Dim termin(30): Dim miktar(30)
tarih = Cells(1, 1)
n = 1
Dim ts, kaplan, trabzonspor
trabzonspor = MsgBox(Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("A1") & vbLf _
& " Yolu " & Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("B1") & _
" Dosya Adı Doğru Mu_?", vbYesNo, "Onay")
If trabzonspor = vbNo Then
Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("A1") = ""
Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("B1") = ""
If Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("A1") = "" Then
ts = InputBox("Dosya Yolu", "Dosya Yolu Giriş")
If ts = "" Then Exit Sub
Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("A1") = ts
kaplan = InputBox("Dosya Adı", "Dosya Adı Girişi")
If kaplan = "" Then Exit Sub
Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("B1") = kaplan
End If
Else
Workbooks.Open Filename:=(Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("A1") & "\" & _
Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("B1") & ".xls")
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Do
Windows(Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("B1") & ".xls").Activate
Sheets(n).Select
Set skod1 = Cells(5, 1)
skod2 = Right(skod1, 22): skod = Left(skod2, 11)
Set tes1 = Cells(5, 3)
tes2 = Right(tes1, 5): tes = Left(tes2, 3)
sontestar = Cells(16, 1)
sonirs = Cells(16, 2)
sonadet = Cells(16, 3)
acil = Cells(13, 5)
bakiye = Cells(13, 4)
satır = Cells(21, 1)
If satır <> "Keine Eintragungen vorhanden !" And satır <> "" Then
s = 0
Do
termin(s) = CDate(Cells(21 + s, 1))
miktar(s) = Cells(21 + s, 2)
s = s + 1
' Loop Until Cells(21 + s, 4) <> ""
Loop Until Cells(21 + s, 1) = ""
Windows("Kitap1.xls").Activate
Sheets("sayfa1").Select
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
Cells(3 + mn, 3).Select: ActiveCell.FormulaR1C1 = tes
Cells(3 + mn, 4).Select: ActiveCell.FormulaR1C1 = sontestar
Cells(3 + mn, 5).Select: ActiveCell.FormulaR1C1 = sonirs
Cells(3 + mn, 6).Select: ActiveCell.FormulaR1C1 = sonadet
Cells(3 + mn, 9).Select: ActiveCell.FormulaR1C1 = bakiye
Cells(3 + mn, 10).Select: ActiveCell.FormulaR1C1 = acil
For j = 0 To s - 1
Cells(3 + mn, 7).Select: ActiveCell.FormulaR1C1 = termin(j)
Cells(3 + mn, 8).Select: ActiveCell.FormulaR1C1 = miktar(j)
Cells(3 + mn, 1).Select: ActiveCell.FormulaR1C1 = skod
termin(j) = "": miktar(j) = ""
mn = mn + 1
Next j
n = n + 1: s = 0
Else
n = n + 1: s = 0
End If
Loop Until n = 16
Workbooks(Workbooks("Kitap1.xls").Sheets("Sayfa2").Range("B1") & ".xls").Close
End If
End Sub
bilgi verirseniz
 
Ihsan bey ellerinize sağlık gayet güzel olmuş elimdeki dosyaya göre uyarladım ve sorunsuz çalıştı tekrar teşekkürler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst