*.xls dosyasında veri almak

[k0081]

Merhaba arkadaşlar;

c:\deneme\ klasörü içinde bulunan excel tablosundan istenen veriyi command buton ile nasıl alabilirim ?

1- veri alınacak *.xls dosya klasörde mevcut değil ise mesaj versin dosya yok gibi..

2- dosya var ise B2:B300 ile C2:C300 arasındaki veriyi alsın. (*.xls)

3- kodun çalıştığı tabloda veriyi : B3:B300 ile C3:C300 aralığına alsın. (*.xlsm)

4- Kodun çalışacağı excel tablosunun uzantısı *.xlsm dir.

yardımcı arkadaşa şimdiden teşekkür ederim.

 

[PLİNT]

Merhaba
İstediğiniz sadece "B2:C300" aralığındaki değerleri almak içinse aşağıdaki gibi yeterli olacaktır

[SIZE="2"]Private Sub CommandButton1_Click()
Dim a As Object
Dim x
Set x = CreateObject("scripting.filesystemobject")
If x.FileExists("C:\Deneme\[COLOR="Blue"]Kitap1.xls[/COLOR]") = False Then MsgBox "Dosya Bulunamadı": Exit Sub
Application.ScreenUpdating = False
Set a = GetObject("C:\Deneme\[COLOR="blue"]Kitap1.xls[/COLOR]")
ActiveSheet.Range("B2:C300").Value = a.[COLOR="Blue"]Worksheets(1)[/COLOR].Range("B2:C300").Value
a.Close
Application.ScreenUpdating = True
End Sub[/SIZE]

 

[k0081]

PLİNT

Hocam çok teşekkür ederim. Tamamdır.

kitap1.xls yi kod arayıp bulursa süper olur. Yani Tablonun çalıştığı klasör içinde *.xls uzantılı dosya bakıp adını ve yoluna alırsa çok iyi olur. Vaktiniz olursa.. yoksa bu hali ile de kullanışlı..

Tekrar Teşekkür ederim.

 

[svorm]

Merhaba

Alttaki benim forumdan faydalandığım listeleme ile ilgili bir kod,
işinize yarayabilir.

Sub ilk()
Set ds = CreateObject("Scripting.FileSystemObject")
Dim yol
Set yol = ds.GetFolder("C:\Users\Alic\Desktop")

j = [C65000].End(3).Row + 1
Dim Dosya As String, i As Long
Dosya = Dir(yol & "\*.xls*")
While Dosya <> ""
DoEvents
Cells(j, 3) = yol & "\" & Dosya
j = j + 1
Dosya = Dir
Wend
End Sub

Buda kaynak gösterek yapabileceğiniz farklı bir yol

Sub Dosya_Listele()
Columns("A:A").ClearContents
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Liste2 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste2(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
Dosya = Dir(Yol & "\*.xls*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
ekle = ""
If Right(Yol, 1) <> "\" Then ekle = "\"
Cells(j, 1) = Yol & ekle & Dosya
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
On Error Resume Next
Liste2 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[k0081]

svorm;

Teşekkürler, inceliyorum