• DİKKAT

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

Kitabların içindeki bir hücreyi alma

C

corsan75

Katılım
19 Ocak 2010
Mesajlar
89
Excel Vers. ve Dili
excel 2007 türkçe
şimdi ben A sütununa kitapların ismini değilde o çalışma kitabındaki b5 hücresini aldırmak istiyorum acaba bunun için makroda bir değişiklik yapmanız mümkünmü.birde b5 hücresini mümkünse değer olarak aldırmak istiyorum yada b5 olmasada sayfa isimlerini değil çalışma kitaplarının ismini alsın ikiside olabilir. formül olmadan nasıl olabilir acaba şimdiden teşekkür ederim.









Sub laribas()
Dim yol As String, dosya As String
Dim syf As Worksheet, kop As Range, yap As Integer
Dim bas As Range, bit As Range
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = Dir(yol & "*.xls")
Do
If dosya = ThisWorkbook.Name Then GoTo a:
Workbooks.Open yol & dosya
ThisWorkbook.Activate
For Each syf In Workbooks(dosya).Worksheets
Set bas = syf.Range("A2")
Set bit = syf.Range("A1").SpecialCells(xlCellTypeLastCell)
yap = Range("A65536").End(xlUp).Row + 1
Set kop = Workbooks(dosya).Worksheets(syf.Name).Range(bas, bit)
kop.Copy Range("B" & yap)
Range(Cells(yap, "A"), Cells(yap + kop.Count - 1, "A")) = syf.Name
Next syf
Workbooks(dosya).Close False
a:
dosya = Dir
Loop Until dosya = ""
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır.", vbInformation, "T A M A M"
End Sub
 
Ömer' Alıntı:
Merhaba,

Dosya adlarını A sütununa yazar.

Kod: 
Sub DosyaAdi()
 
    Dim DosyaYolu As String, Ara As String, i As Long
 
    DosyaYolu = ThisWorkbook.Path & "\"
    Ara = Dir(DosyaYolu & Application.PathSeparator & "*.xls", vbDirectory)
 
    Range("A:A").ClearContents
    Do While Ara <> ""
        Cells(i + 1, 1) = Ara
        i = i + 1
        Ara = Dir
    Loop
 
End Sub

Detaylı bilgi linkte mevcuttur.

http://www.excel.web.tr/f14/bir-klasordeki-dosyalaryn-isimlerini-excelde-listeleme-t4518.html

.
Genişletmek için tıkla ...



Ömer hocam sağolun varolun ama ben anlatamadım istediğimi yukarda yazdığım makrodaki gibi çalışma kitabımdaki verilerin tamamını almayı ama yanlarına sayfa isimlerini değilde çalışma kitabımın isimlerini almak istiyorum.sizin makronuzda sadece klasörümdeki dosyaların isimlerini yazıyor eğer yardımcı olabilirseniz çok sevinirim.
 
Aşağıdaki kodu deneyiniz.

Kod: 
Sub AKTAR()
    Dim Satir As Long, Yol As String
    Dim Dosya As String, Sayfa As Worksheet
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Yol = ThisWorkbook.Path
    Dosya = Dir(Yol & "\*.xls")
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    S1.Range("A:C").ClearContents
    Satir = 1
    
    Do While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            Set K2 = Workbooks.Open(Dosya)
            For Each Sayfa In K2.Worksheets
                S1.Cells(Satir, 1) = Sayfa.Range("B5")
                S1.Cells(Satir, 2) = Sayfa.Name
                S1.Cells(Satir, 3) = Dosya
                Satir = Satir + 1
            Next
            K2.Close False
        End If
        Dosya = Dir
    Loop
                    
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
                    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Sub AKTAR()
Dim Satir As Long, Yol As String
Dim Dosya As String, Sayfa As Worksheet
Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Yol = ThisWorkbook.Path
Dosya = Dir(Yol & "\*.xls")

Set K1 = ThisWorkbook
Set S1 = K1.Sheets("Sayfa1")

S1.Range("A:C").ClearContents
Satir = 1

Do While Dosya <> ""
If Dosya <> ThisWorkbook.Name Then
Set K2 = Workbooks.Open(Dosya)
For Each Sayfa In K2.Worksheets
S1.Cells(Satir, 1) = Sayfa.Range("B5")
S1.Cells(Satir, 2) = Sayfa.Name
S1.Cells(Satir, 3) = Dosya
Satir = Satir + 1
Next
K2.Close False
End If
Dosya = Dir
Loop

Set K2 = Nothing
Set S1 = Nothing
Set K1 = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub


hocam hata verdi kırmızı satırlı yerden mümkünse düzeltebilirmiyiz.
 
Kodları deneyerek foruma ekledim. Dosya isimlerini ve uzantılarını kontrol ediniz.
 
Alternatif olması açısından şu kodları da deneyebilirsiniz;

Kod: 
Sub Emre()
    Dim evn As Object, dosya As Object
    Dim syf As Worksheet
    Dim yol As String
    Dim i As Integer
    On Error Resume Next
    yol = ThisWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set evn = CreateObject("Scripting.FilesystemObject"): i = 1
    For Each dosya In evn.getfolder(yol).Files
        If dosya.Name <> ThisWorkbook.Name Then
            If VBA.Right(dosya.Name, 4) = "xlsx" Or _
                VBA.Right(dosya.Name, 4) = "xlsm" Or _
                VBA.Right(dosya.Name, 3) = "xls" Then
                Set ac = Workbooks.Open(dosya)
                For Each syf In ActiveWorkbook.Worksheets
                    With ThisWorkbook.Sheets(1)
                        .Cells(i, 1) = syf.Range("A5").Value
                        .Cells(i, 2) = syf.Name
                        .Cells(i, 3) = dosya.Name
                    End With
                    i = i + 1
                Next syf
            End If
        End If
    ac.Close False
    Next dosya
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    i = Empty: yol = vbNullString
    Set evn = Nothing: Set dosya = Nothing: Set syf = Nothing
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst