ExecuteExcel4Macro- 1.sayfa tarifi

[huseyin610]

Merhaba,

Range("A1").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[B.xlsx]ambar'!R1C1")

Ben bu kodu kullanarak B isimli excel dosyasının ambar adındaki sayfasından veri alıyorum.

Ancak ambar ismi değişebiliyor ,ancak hep ilk sırada o yüzden buraya ne yazmalıyım ambar yerine

Saygılarımla,

 

[halit3]

Merhaba,

Range("A1").Value = Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[B.xlsx]ambar'!R1C1")

Ben bu kodu kullanarak B isimli excel dosyasının ambar adındaki sayfasından veri alıyorum.

Ancak ambar ismi değişebiliyor ,ancak hep ilk sırada o yüzden buraya ne yazmalıyım ambar yerine

Saygılarımla,

Bunu denermisiniz.

Private Sub CommandButton1_Click()
Klasor = ThisWorkbook.Path & "\"
Dosya = "B.xlsx"
deg = "'" & Klasor & "[" & Dosya & "]" & x & "'!R"
Cells(1, 1).Value = "=" & deg & 1 & "C" & 1
Cells(1, 1).Replace What:="=", Replacement:=""
alan1 = Cells(1, 1).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
sayfaadi = zaman
deg = "'" & Klasor & "[" & Dosya & "]" & sayfaadi & "'!R1C1"
Range("A1").Value = Application.ExecuteExcel4Macro(deg)
End Sub

 

[huseyin610]

Çok teşekkür ederim.Süper oldu

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Option Explicit
 
Sub KAPALI_DOSYADAKİ_İLK_SAYFADAN_VERİ_AL()
    Dim Dosya_Yolu As String, Cn As Object, Cat As Object, Sayfa_Adi As String, Nesne As Object
 
    Set Cn = CreateObject("ADODB.Connection")
    Set Cat = CreateObject("ADOX.Catalog")
    
    Dosya_Yolu = ThisWorkbook.Path & "\"
    
    Cn.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & Dosya_Yolu & "B.xlsx;"
    Cat.ActiveConnection = Cn
    
    Set Nesne = Cat.Tables
    Sayfa_Adi = Replace(Nesne.Item(0).Name, "$", "")
 
    Range("A1").Value = Application.ExecuteExcel4Macro("'" & Dosya_Yolu & "[B.xlsx]" & Sayfa_Adi & "'!R1C1")
 
    Set Cn = Nothing
    Set Cat = Nothing
End Sub

 

[huseyin610]

Tekrar Merhaba,

1.Kodun sonuna for next döngüsü ekledim ve A1 ile V750 hücresindeki verilerin tamamını çekmek için ancak çok yavaş çalışıyor.Ayrıca eğer boşluklar varsa bunları 0 olarak alıyor.Boşluk olarak almıyor.

Saygılarımla,

Private Sub CommandButton1_Click()
Dim men As Integer, zen As Integer
Klasor = ThisWorkbook.Path & "\"
Dosya = "B.xlsx"
deg = "'" & Klasor & "[" & Dosya & "]" & X & "'!R"
Cells(1, 1).Value = "=" & deg & 1 & "C" & 1
Cells(1, 1).Replace What:="=", Replacement:=""
alan1 = Cells(1, 1).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
sayfaadi = zaman
For zen = 1 To 22
For men = 1 To 750
deg = "'" & Klasor & "[" & Dosya & "]" & sayfaadi & "'!R" & men & "C" & zen

Cells(men, zen).Value = Application.ExecuteExcel4Macro(deg)

Next men
Next zen

End Sub

 

[Korhan Ayhan]

Selamlar,

Kodlarınızın başına;

Application.ScreenUpdating = False

Kodlarınızın sonuna;

Application.ScreenUpdating = True

Komutlarını ekleyip deneyin. Yine sonuç yavaşsa forumdaki ADO-DAO konularını inceleyin.

 

[halit3]

Korhan Beyin dediği gibi kodların başına ve sonuna (Application.ScreenUpdating) bu kodu ekleyince birazcık hızlanır ama bu yöntemle veri alınırken veri aralığı ne kadar büyük olursa o kadar kad yavaşlıyacaktır.
sıfır durumunu aşağıdaki kadda düzelttim.

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Klasor = ThisWorkbook.Path & "\"
Dosya = "B.xlsx"
deg = "'" & Klasor & "[" & Dosya & "]" & x & "'!R1C1"
Cells(1, 1).Value = "=" & deg
Cells(1, 1).Replace What:="=", Replacement:=""
alan1 = Cells(1, 1).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
sayfaadi = zaman
deg = "'" & Klasor & "[" & Dosya & "]" & sayfaadi & "'!R"
For zen = 1 To 22
For men = 1 To 750
If Application.ExecuteExcel4Macro(deg & men & "C" & zen) <> "" Then
Cells(men, zen).Value = Application.ExecuteExcel4Macro(deg & men & "C" & zen)
End If
Next men
Next zen
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub