Değer yapıştırma

[cimbom05]

İyi akşamlar,
Aşağıdaki kod ile C:\Belgeler klasörü içerisindeki dosyaları kopyala-değerleri yapıştır işlemini başarılı bir şekilde gerçekleştiriyor. Bu kodu klasörü seçecek şekilde geliştirebilirmiyiz. Yani yapmak istediğimiz şey, sabit olarak c:\Belgeler klasörü değilde, değerleri yapıştırmak istediğimiz dosyaların bulunduğu klasörü seçmek için seçebileceğimiz bir pencere açılsa. Teşekkür ederim.

KOD:
Option Explicit

Sub FORMÜLLERİ_KOPYALA_DEĞER_OLARAK_YAPIŞTIR()
Dim Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet

Application.ScreenUpdating = False

If CreateObject("Scripting.FileSystemObject").GetFolder("C:\Belgeler").Files.Count = 0 Then GoTo Son

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder("C:\Belgeler").Files

Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)

For Each Sayfa In Kaynak_Dosya.Sheets
Sayfa.Select
Cells.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues
Range("A1").Select
Application.CutCopyMode = False
Next
Kaynak_Dosya.Close True
Next
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Exit Sub
Son:
Application.ScreenUpdating = True
MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

 

[janveljan]

Aşağıdaki şekilde değişiklik yapın.

Set Yol = CreateObject("Shell.Application").BrowseForFolder _
               (0, "Lütfen bir klasor seçin !", 1)
If Not TypeName(Yol) = "Nothing" Then Set YolItem = Yol.self
MyPath = YolItem.Path
If CreateObject("Scripting.FileSystemObject").GetFolder ([COLOR=red]MyPath[/COLOR]).Files.Count = 0 Then GoTo Son
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder([COLOR=red]MyPath[/COLOR])Files

 

[cimbom05]

İyi akşamlar, Sayın janjelvan emeğiniz için teşekkür ederim. Ancak verdiğiniz şekilde sanırım değiştiremedim. Kod hata veriyor.

KOD:
Option Explicit
Sub FORMÜLLERİ_KOPYALA_DEĞER_OLARAK_YAPIŞTIR()
Dim Dosya As Object, Yol As Workbook, Sayfa As Worksheet
Application.ScreenUpdating = False
Set Yol = CreateObject("Shell.Application").BrowseForFolder _
(0, "Lütfen bir klasor seçin !", 1)
If Not TypeName(Yol) = "Nothing" Then Set YolItem = Yol.self
MyPath = YolItem.Path
If CreateObject("Scripting.FileSystemObject").GetFolder(MyPath).Files.Count = 0 Then GoTo Son
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(MyPath).Files
Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
For Each Sayfa In Kaynak_Dosya.Sheets
Sayfa.Select
Cells.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues
Range("A1").Select
Application.CutCopyMode = False
Next
Kaynak_Dosya.Close True
Next
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Exit Sub
Son:
Application.ScreenUpdating = True
MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

Ben nerde yanlış yaptım?

 

[ridvan2111]

If CreateObject("Scripting.FileSystemObject").GetFold er(MyPath).Files.Count = 0 Then GoTo Son
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFold er(MyPath).Files

hata renkli yerlerdeki yazım hataları olabilirmi?
GetFolder (MyPath) şeklinde olmalı

 

[cimbom05]

İlginize teşekkür ederim ridvan2111
Dosyayı ekliyorum. Önerdiğiniz değişikliği yaptım ama,
Set yol
ile başlayan satırda hata veriyor.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Kodların en başındaki "Option Explicit" deyimini kullandığınız sürece Dim ile başlayan tüm tanımlamaları yapmanız gerekmektedir. Aksi halde kod hata verecektir.

Option Explicit
 
Sub FORMÜLLERİ_KOPYALA_DEĞER_OLARAK_YAPIŞTIR()
    Dim Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
    Dim Klasör As Object, Dosya_Yolu As String
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFoldeR(0, "Lütfen bir klasör seçin !", 1)
 
    If Klasör Is Nothing Then
    MsgBox "İşleme devam edebilmek için lütfen klasör seçiniz !", vbExclamation, "Dikkat !"
    Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Dosya_Yolu = Klasör.Self.Path
 
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
 
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
 
    Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 
        For Each Sayfa In Kaynak_Dosya.Sheets
            Sayfa.Select
            Cells.Copy
            Range("A1").PasteSpecial Paste:=xlPasteValues
            Range("A1").Select
            Application.CutCopyMode = False
        Next
 
    Kaynak_Dosya.Close True
 
    Next
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

 

[cimbom05]

Teşekkürler Korhan Bey,

"Kodların en başındaki "Option Explicit" deyimini kullandığınız sürece Dim ile başlayan tüm tanımlamaları yapmanız gerekmektedir. Aksi halde kod hata verecektir."

Özellikle bu tanımlama için teşekkür ederim.