Dosya açıkken de veri kopyalama yapabilmesi?

[mars2]

İyi Günler;

Aşağıdaki kodla kapalı dosyadan veri kopylama yapıyorum ancak, açık olduğunda hata mesajı vermektedir. Açık olduğunda da verileri kopyalayabilmem için kodda ne gibi değişiklik yapılması gerektiğ hakkında yardımlarınızı beklemekteyim.


Dim Msg As String, Ans As Variant

Dim w As Workbook

Ans = MsgBox("DOSYADAN VERİ ALMAK İSTİYOR MUSUNUZ ?", vbQuestion + vbYesNo, "Günceleme???")


Select Case Ans

Case vbYes


Workbooks.Open Filename:="………………………..xls", Password:="…………."

Sheets("Liste").Select

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.EnableEvents = False



Range("A2:AF3000").Select



MsgBox ActiveSheet.Name & " Sayfasını Açtınız", 1, ActiveSheet.Name

 

[PLİNT]

Merhaba
Aşağıdaki işaretli aralıkları ekleyerek deneyin

Dim Msg As String, Ans As Variant

Dim w As Workbook

Ans = MsgBox("DOSYADAN VERİ ALMAK İSTİYOR MUSUNUZ ?", vbQuestion + vbYesNo, "Günceleme???")


Select Case Ans

Case vbYes
'___________________________________________________
For Each j In Application.Workbooks
If j.Name = "______.xls" Then
Windows("_______.xls").Activate
GoTo 10
End If
Next
'_________________________________________________

Workbooks.Open Filename:="………….", Password:="…………."
'_____________
10:
'_____________

Sheets("Liste").Select

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.EnableEvents = False



Range("A2:AF3000").Select

 

[mars2]

Sayın Plint;

İlgi ve alakanız için teşekkürler.
Konu hakkında sorum olacaktı.

1- If j.Name = "______.xls" Then
Windows("_______.xls").Activate
Her ikisine de veri alacağımız dosya ismini yazmamız mı gerekiyor.

"D:\belgeler\...xls"

Eğer belge kapalı ise yeniden kapansın açık ise kapanmasın


Workbooks("................xls").Close Savechanges:=False

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True

Sheets("...............").Activate

For Each w In Application.Workbooks
w.Save
Next w

 

[PLİNT]

Merhaba
Evete boş bırakılmış yerlere veri alınacak dosya adı yazın.

kod sayfasının üst kısmına (boşluğa) şu kodu ekleyin;

Public dosyaaçıkmı As String

Yukarıdaki kodlarınıza aşağıdaki yıldızlı satırı ekleyin.

Dim Msg As String, Ans As Variant

Dim w As Workbook

Ans = MsgBox("DOSYADAN VERİ ALMAK İSTİYOR MUSUNUZ ?", vbQuestion + vbYesNo, "Günceleme???")

Select Case Ans

Case vbYes
'___________________________________________________
For Each j In Application.Workbooks
If j.Name = "VERİKİTABI.xls" Then
Windows("VERİKİTABI.xls").Activate
GoTo 10
End If
Next
'_________________________________________________

Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "VERİKİTABI.xls", Password:="12345"
'*******************************
dosyaaçıkmı = "hayır"
'**************************
'_____________
10:
'_____________

Sheets("Liste").Select

Application.ScreenUpdating = False

Dosyayı kapatan kodlarınızda, kapatma işlemi yapan satırı "İf" satırları arasına alın.

If dosyaaçıkmı = "hayır" Then

Workbooks("VERİKİTABI.xls").Close Savechanges:=False

dosyaaçıkmı = ""
End If
ThisWorkbook.Activate

 

[mars2]

Sayın PLİNT;

Yardımlarınız için teşekkürler.

kodları yerine koymama rağmen yine de kapatmaktadır.

kodu tamamını aşağıdadır düzeltilmesi gereken noktalarda yardımlarınızı beklemekteyim.


Public dosyaaçıkmı As String


Sub Düğme1_Tıklat()

Dim Msg As String, Ans As Variant

Dim w As Workbook


Ans = MsgBox("DOSYADAN VERİ ALMAK İSTİYOR MUSUNUZ ?", vbQuestion + vbYesNo, "Günceleme???")

Select Case Ans

Case vbYes

For Each j In Application.Workbooks
If j.Name = "______.xls" Then
Windows("_______.xls").Activate
GoTo 10
End If
Next

Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "VERİKİTABI.xls", Password:="12345"

dosyaaçıkmı = "hayır"

10:

Sheets("Liste").Select

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.EnableEvents = False

Range("A2:AF3000").Select

MsgBox ActiveSheet.Name & Chr(13) & " Adlı Sayfayı Açtınız", 1, ActiveSheet.Name

Range(Selection,Selection.End(xlToRight)).Select
Range(Selection,Selection.End(xlDown)).Select

Selection.Copy
Windows("LİSTE.xls").Activate
Worksheets("Liste").Visible =True
Sheets("Liste").Select
Range("A1").Select
ActiveSheet.Paste

Application.CutCopyMode = False
Range("A1").Select
Selection.End(xlDown).Select
Windows("LİSTE.xls").Activate

Worksheets("Liste").Visible =False
Application.DisplayAlerts= True
Application.ScreenUpdating= True
Application.EnableEvents= True

Sheets("formu").Activate

If dosyaaçıkmı = "hayır" Then

workbooks("VERİKİTABI.xls").Close Savechanges:=False

dosyaaçıkmı = ""

End If

For Each w In Application.Workbooks

w.Save

Next w



Dim x As Integer, WScript As Object

Set WScript = CreateObject("WScript.Shell")

x = WScript.popup("Verileriniz Başarılı Bir Şekilde Güncellendi ve Save Edildi.", 1, "KAYYIMLIK")

Select Case x

End Select

Case vbNo

GoTo Quit:

End Select

Quit:
End Sub

 

[PLİNT]

Merhaba
Son eklediğiniz yukarıdaki, kodlarda açan ve kapatan kısımlarında veri aldığınız dosya adı (VERİKİTABI.xls yerine) ve şifresi olmalı

Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "VERİKİTABI.xls", Password:="12345"

workbooks("VERİKİTABI.xls").Close Savechanges:=False

 

[mars2]

Sayın PLİNT;
Konu hakkında yardımlarınız için teşekkür ederim.