Kopyala makrosunun revize edilmesi gerekiyor.

[s.savas]

Merhaba arkadaşlar.
Aşağıdaki kod sanırım Halit usta tarafından yazılmıştı. Kendisine teşekkür ediyorum. Bu kod ile istenilen herhangi bir klasördeki bir kitapta bulunan istediğiniz sayfayı istediğiniz yere kopyalayabiliyorsunuz.Fakat kod, kopyalama işlemini yaparken hücreleri yapıları ile birlikte kopyalamıyor. Bunun düzenlenmesini istiyorum.

Sub veri_al()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

a = Application.GetOpenFilename(FileFilter:="Excel Workbooks,*.xls", Title:="Open a File", MultiSelect:=False)

'a = Application.GetOpenFilename("All Files (*.*),*.*.")
If a = False Then
MsgBox "Kaynak klasörü seçmediniz"
Exit Sub
End If

Kaynak = Mid(a, 1, Len(a) - Len(Dir(a)) - 1)
deg = "'" & Kaynak & "\" & "[" & Dir(a) & "]" & "x" & "'!R"

Cells(1, 1).Value = "=" & deg & 1 & "C" & 1
Cells(1, 1).Replace What:="=", Replacement:=""

alan1 = Worksheets(ActiveSheet.Name).Cells(1, 1).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
sayfaadı = Mid(alan1, k + 1, yer)
End If
Next

Cells(1, 1).Value = sayfaadı

Dim Dosya
Dim wb As Workbook
Dosya = Dir(a)

If a = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Set wb = Workbooks.Open(a)
yeni_dosya_adı = ActiveWorkbook.Name
Windows(yeni_dosya_adı).Activate
Sheets(sayfaadı).Select
On Error Resume Next
Application.DisplayAlerts = False
Cells.Select
Selection.Copy
ActiveWindow.Close
Windows(dosya_adı).Activate
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
ActiveWindow.WindowState = xlMaximized
Application.CutCopyMode = False
MsgBox "işlem tamam"
End Sub

Yardımcı olacak arkadaşlara teşekkür ederim.

 

[s.savas]

Halit hocam kod size ait olduğu için diğer hocalar müdahale etmek istemiyorlar sanırım.Müsait olduğunuzda ilgilenirseniz sevinirim.

 

[mancubus]

merhaba.
kodun aşağıdaki kısımları ctrl+C ve ctrl+V niteliğindedir. yani olduğu gibi kopyalıyor olması lazım.




düzeltme: pardon. veri alınan dosya kapatılarak yeni dosyaya kopyalanıyormuş. bu durumda sadece verileri kopyalıyor zannediyorum.

 

[halit3]

Halit hocam kod size ait olduğu için diğer hocalar müdahale etmek istemiyorlar sanırım.Müsait olduğunuzda ilgilenirseniz sevinirim.

Dün bu konuya bakmıştım ama anlıyamadığım için cevap veremiyorum.aşağıdaki bölümde söylediğinizi anlıyamadım."Hücrelerin yapılarından" kastınız ney

hücreleri yapıları ile birlikte kopyalamıyor. Bunun düzenlenmesini istiyorum.

 

[mancubus]

Halit hocam.

Biçimler/format kastediliyor.

kodun aşağıdaki böülümünü düzenlerseniz oluyor.

Set wb = Workbooks.Open(a)
yeni_dosya_adı = ActiveWorkbook.Name
Windows(yeni_dosya_adı).Activate
Sheets(sayfaadı).Select
On Error Resume Next
Application.DisplayAlerts = False
Cells.Select
Selection.Copy
'ActiveWindow.Close [COLOR="red"]' bu satırı siliyoruz[/COLOR]
Windows(dosya_adı).Activate
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
ActiveWindow.WindowState = xlMaximized
[COLOR="Red"]Windows(yeni_dosya_adı).Close[/COLOR] 'bu satırı buraya ekliyoruz.
Application.CutCopyMode = False
MsgBox "işlem tamam"

 

[halit3]

Hücreleri farmülleri ve biçimlerine göre veri almak istiyorsanız?
Kodları Sayın mancubus 'un gösterdiği şekilde yapanız.

 

[s.savas]

Mancubus arkadaşım ve Halit hocam, ilgilerinize ayrı ayrı teşekkür ederim. Talep yerine gelmiştir.

 

[halit3]

Mancubus arkadaşım ve Halit hocam, ilgilerinize ayrı ayrı teşekkür ederim. Talep yerine gelmiştir.

iyi çalışmalar.