Makroya küçük bir ilave

[kemalist]

Arkadaşlar Merhaba; yukarıdaki Excel makrosu normal olarak çalışıyor, benim istediğim küçük bir değişiklik mavi satıra kadar makronun çalışması ;mavi satırda yazılı olan Dosya ismi sürekli değişiyor.Bu ismi TARGET.xlsm dosyasında E2 hücresine yazdığımda aktif olması ve makronun geri kalanının çalışmaya devam etmesi…
İlginiz için şimdiden teşekkür eder iyi hafta sonları dilerim…

Açıklama dosyası ve makro ektedir...

Sub XC()
Windows("AS.xla").Activate
Range("A1:AT403").Select

Selection.Copy



Windows("20170210.xlsx").Activate




Sheets("Sayfa2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Copy
Windows("TARGET.xlsm").Activate
Sheets("R").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("ALERTER.xlsm").Activate
Sheets("R").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("ANA SAYFA").Select
Range("D2").Select
Windows("TARGET.xlsm").Activate
Sheets("ANA SAYFA").Select
Range("E3").Select
End Sub

 

[PLİNT]

Merhaba
Yukarıdaki mavi bölümün yerine aşağıdaki kodları yapıştırıp deneyiniz,
Kırmızı bölüm "E" hücresinin bulunduğu sayfa ve kitap adını ayarlarsınız;

'....
' kodlarınız
'....

[SIZE="2"]
[COLOR="Red"]x = Workbooks("TARGET.xlsm").Sheets("Sayfa1").[E2][/COLOR]
If x = "" Then Exit Sub
For Each a In Application.Workbooks
If InStr(1, a.Name, x, vbTextCompare) > 0 Then
a.Activate
Exit For
Else
Exit Sub
End If
Next[/SIZE]

'....
'.....

 

[kemalist]

Merhaba
Yukarıdaki mavi bölümün yerine aşağıdaki kodları yapıştırıp deneyiniz,
Kırmızı bölüm "E" hücresinin bulunduğu sayfa ve kitap adını ayarlarsınız;

'....
' kodlarınız
'....

[SIZE="2"]
[COLOR="Red"]x = Workbooks("TARGET.xlsm").Sheets("Sayfa1").[E2][/COLOR]
If x = "" Then Exit Sub
For Each a In Application.Workbooks
If InStr(1, a.Name, x, vbTextCompare) > 0 Then
a.Activate
Exit For
Else
Exit Sub
End If
Next[/SIZE]

'....
'.....

KOd çalışıyor fakat işlem yapmıyor F8 ile elle çelıştırdığımda Sub () ile Next arasında kısır döngü olarak çalışıyor.

 

[PLİNT]

Şöylede olabilir (mavi bölümün yerine)
Eğer "e2" hücresinde dosya adı uzantısı ile birlikte yazılı ise kırmızı bölümü silin.

On Error Resume Next
x = [COLOR="Blue"]Workbooks("TARGET.xlsm").Sheets("Sayfa1")[/COLOR].[E2]
If x = "" Then Exit Sub
Workbooks(x [COLOR="Red"]& ".xlsx"[/COLOR]).Activate
If Err > 0 Then MsgBox x & " isimli dosya bulunamadı": Exit Sub

Yalnız dosya arka planda açık olmalıdır
eğer kapalı olma ihtimali de varsa açılacaksa kodları şöyle değişelim.
(dosya yolunu düzenlersiniz)

On Error Resume Next
x = [COLOR="Blue"]Workbooks("TARGET.xlsm").Sheets("Sayfa1").[/COLOR][E2]
If x = "" Then Exit Sub
Workbooks(x [COLOR="Red"]& ".xlsx"[/COLOR]).Activate
If Err > 0 Then
Err = 0
Workbooks.Open [COLOR="Red"]ThisWorkbook.Path & "\"[/COLOR] & x [COLOR="Red"]& ".xlsx"[/COLOR]
If Err > 0 Then MsgBox x & " isimli dosya bulunamadı": Exit Sub
End If

 

[kemalist]

Sayın Plint işlem tamam.Teşekkür ederim.