Dosyadan İsim Çekme yardım 2

[sosorry]

iyi akşamlar
ekteki dosya için yardım edebilir misiniz?

 

[sosorry]

açıklayabildim mi?

 

[sosorry]

:S :S :S yardım lütfenn

 

[leumruk]

Merhaba,
Aşağıdaki kodu kullanın.

Sub VeriAl()
dosya = [a6].Text
[b6] = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\a\[" & dosya & "]Sayfa1'!R1C1")
End Sub

 

[sosorry]

Merhaba,
Aşağıdaki kodu kullanın.

Sub VeriAl()
dosya = [a6].Text
[b6] = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\a\[" & dosya & "]Sayfa1'!R1C1")
End Sub

çalışıyor ancak a sütununa da a klasöürün içindeki kitapların isimlerinin yazması gerek kitap ismine karşılık gelen hücrede tazması lazım. ( umarım anlatabilmişimdir karışık oldu gibi oldu :s ) bu komutla nasıl birleştiririm yani? Sub dosya_al()
Dim fso As Object, fs As Object, sat As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Range("A:A").ClearContents
For Each fs In fso.getfolder(ThisWorkbook.Path & "\a").Files
If Right(fs.Name, 4) = ".xls" Then
sat = sat + 1
Cells(sat, "A").Value = Left(fs.Name, Len(fs.Name) - 4)
End If
Next
MsgBox "Dosyalar A sütununa yazıldı."

End Sub

 

[leumruk]

Kodunuzu aşağıdaki ile değiştirin.

Sub dosya_al()
Dim fso As Object, fs As Object, sat As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Range("A:A").ClearContents
For Each fs In fso.getfolder(ThisWorkbook.Path & "\a").Files
    If Right(fs.Name, 4) = ".xls" Then
        sat = sat + 1
        Cells(sat, "A").Value = Left(fs.Name, Len(fs.Name) - 4)
        yol = ThisWorkbook.Path & "\a\"
        Dosya = fs.Name
        Cells(sat, "B").Value = Application.ExecuteExcel4Macro("'" & yol & "[" & Dosya & "]Sayfa1'!R1C1")
    End If
Next
MsgBox "Dosyalar A sütununa yazıldı."
End Sub

 

[sosorry]

Kodunuzu aşağıdaki ile değiştirin.

Sub dosya_al()
Dim fso As Object, fs As Object, sat As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Range("A:A").ClearContents
For Each fs In fso.getfolder(ThisWorkbook.Path & "\a").Files
    If Right(fs.Name, 4) = ".xls" Then
        sat = sat + 1
        Cells(sat, "A").Value = Left(fs.Name, Len(fs.Name) - 4)
        yol = ThisWorkbook.Path & "\a\"
        Dosya = Left(fs.Name, Len(fs.Name))
        Cells(sat, "B").Value = Application.ExecuteExcel4Macro("'" & yol & "[" & Dosya & "]Sayfa1'!R1C1")
    End If
Next
MsgBox "Dosyalar A sütununa yazıldı."
End Sub

şahane oldu çok teşekkür ederim.

 

[leumruk]

şahane oldu çok teşekkür ederim.

Eğer dosyalarınıza 0 değerleri girmeyecekseniz, aşağıdaki kodu kullanabilirsiniz. Böylece boş hücrelere 0 değeri vermemiş olur.

Sub dosya_al()
Dim fso As Object, fs As Object, sat As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Range("A:A").ClearContents
For Each fs In fso.getfolder(ThisWorkbook.Path & "\a").Files
    If Right(fs.Name, 4) = ".xls" Then
        sat = sat + 1
        Cells(sat, "A").Value = Left(fs.Name, Len(fs.Name) - 4)
        yol = ThisWorkbook.Path & "\a\"
        hucre = Application.ExecuteExcel4Macro("'" & yol & "[" & fs.Name & "]Sayfa1'!R1C1")
        If hucre <> 0 Then
        Cells(sat, "B").Value = hucre
        End If
    End If
Next
MsgBox "Dosyalar A sütununa yazıldı."
End Sub