Makro Yardım

K

kaos64

Katılım
27 Ağustos 2009
Mesajlar
35
Excel Vers. ve Dili
Oficce 2016
Altın Üyelik Bitiş Tarihi
20-12-2024
Merhabalar
Ekteki dosyada 3 adet sorgum var sorgular tetiklemeli çalışıyor. (süreli olarak)
sizden iki ricam var
MAKROSTOP (tetiklemeleri durdurmak için, fakat çalışmıyor.)
Sorgular çalıştığında aşağıdaki sayfalarım değişiriyor ben (dash) ekranında kalsın istiyorum sorgular arka planda çalışsın.
teşekkür ederim.

Kod
Sub AUTO_MAKRO()
On Error Resume Next
DoEvents
Application.OnTime Now + TimeValue("00:00:10"), "MAKRO"
End Sub
Sub AUTO_MAKRO2()
On Error Resume Next
DoEvents
Application.OnTime Now + TimeValue("00:01:00"), "MAKRO2"
End Sub
Sub AUTO_MAKRO3()
On Error Resume Next
DoEvents
Application.OnTime Now + TimeValue("00:01:00"), "MAKRO3"
End Sub
Sub MAKRO()
On Error Resume Next
DoEvents
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Dash")
Set lo = ws.ListObjects("Sorgu1")

lo.QueryTable.Refresh BackgroundQuery:=False

lo.Sort.SortFields.Clear
lo.Sort.SortFields.Add Key:=ws.Range("Sorgu1[[#All],[zaman]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With lo.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
AUTO_MAKRO
End Sub
Sub MAKRO2()
On Error Resume Next
DoEvents
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Misafir")
Set lo = ws.ListObjects("Sorgu2")

lo.QueryTable.Refresh BackgroundQuery:=False

lo.Sort.SortFields.Clear
Sheets("Misafir").Select
Range("Sorgu2").Select
Selection.Copy
Sheets("Dash").Select
Range("H2:O2").Select
ActiveSheet.Paste
AUTO_MAKRO2
End Sub
Sub MAKRO3()
On Error Resume Next
DoEvents
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Dışarda")
Set lo = ws.ListObjects("Sorgu3")

lo.QueryTable.Refresh BackgroundQuery:=False

lo.Sort.SortFields.Clear
lo.Sort.SortFields.Add Key:=ws.Range("Sorgu3[[#All],[zaman]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With lo.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
AUTO_MAKRO3
End Sub
Sub MAKROSTOP()
On Error Resume Next
DoEvents
Application.OnTime RunWhen, "MAKRO", False
Application.OnTime RunWhen, "MAKRO2", False
Application.OnTime RunWhen, "MAKRO3", False
End Sub
Sub TEMIZLE()
On Error Resume Next
Range("H2:O18").Select
Selection.ClearContents
Range("A1").Select
End Sub
 

Ekli dosyalar

tugkan

tugkan

Altın Üye
Katılım
6 Kasım 2004
Mesajlar
481
Excel Vers. ve Dili
Excel 2016
Türkçe 64 BIT
Altın Üyelik Bitiş Tarihi
16-10-2025
1. MAKROSTOP Makrosunu Düzeltme
MAKROSTOP makrosunda bir hata var. Application.OnTime fonksiyonu belirli bir zamanı beklemek için kullanılıyor ve RunWhen adında bir değişken tanımlı değil. Bunu düzeltmek için, tetiklenmiş olan OnTime işlemlerini durdururken doğru zamanı kullanmamız gerekiyor.

Her bir OnTime çağrısını tetiklediğinizde, belirli bir zamanı değişken olarak kaydetmelisiniz ki, MAKROSTOP işlemi bunu iptal edebilsin. İşte güncellenmiş bir örnek:

Kod: 
Dim RunWhen1 As Date, RunWhen2 As Date, RunWhen3 As Date

Sub AUTO_MAKRO()
    On Error Resume Next
    RunWhen1 = Now + TimeValue("00:00:10")
    Application.OnTime RunWhen1, "MAKRO"
End Sub

Sub AUTO_MAKRO2()
    On Error Resume Next
    RunWhen2 = Now + TimeValue("00:01:00")
    Application.OnTime RunWhen2, "MAKRO2"
End Sub

Sub AUTO_MAKRO3()
    On Error Resume Next
    RunWhen3 = Now + TimeValue("00:01:00")
    Application.OnTime RunWhen3, "MAKRO3"
End Sub

Sub MAKROSTOP()
    On Error Resume Next
    Application.OnTime RunWhen1, "MAKRO", False
    Application.OnTime RunWhen2, "MAKRO2", False
    Application.OnTime RunWhen3, "MAKRO3", False
End Sub
2. Sorguların Arka Planda Çalışması
Sayfanın değişmemesini, yani "Dash" sayfasında kalmasını sağlamak için Sheets("Dash").Select veya Sheets("Misafir").Select gibi kodları kaldırmamız gerekiyor. Bunun yerine verileri kopyalama işlemlerini doğrudan sayfa seçim yapmadan yapabiliriz.

Örneğin, MAKRO2 içinde şu satırları:

Kod: 
Sheets("Misafir").Select
Range("Sorgu2").Select
Selection.Copy
Sheets("Dash").Select
Range("H2:O2").Select
ActiveSheet.Paste
Bu işlemi şu şekilde düzenleyelim:

Kod: 
wb.Sheets("Misafir").Range("Sorgu2").Copy
wb.Sheets("Dash").Range("H2:O2").PasteSpecial
Bu değişiklikleri tüm makrolara uyguladığınızda, sorgular arka planda çalışır ve "Dash" sayfasında kalırsınız.

Eğer bu düzenlemeleri uygularsanız, tetikleme sorunlarını çözüp arka planda sorgu işlemlerini gerçekleştirebilirsiniz.
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
324
Excel Vers. ve Dili
Excel 2021 Türkçe
Bu şekilde düzenleyip sonucu paylaşabilir misiniz;


Kod: 
Option Explicit

Dim RunWhen1 As Double
Dim RunWhen2 As Double
Dim RunWhen3 As Double

Sub AUTO_MAKRO()
    On Error Resume Next
    DoEvents
    RunWhen1 = Now + TimeValue("00:00:10")
    Application.OnTime RunWhen1, "MAKRO"
End Sub

Sub AUTO_MAKRO2()
    On Error Resume Next
    DoEvents
    RunWhen2 = Now + TimeValue("00:01:00")
    Application.OnTime RunWhen2, "MAKRO2"
End Sub

Sub AUTO_MAKRO3()
    On Error Resume Next
    DoEvents
    RunWhen3 = Now + TimeValue("00:01:00")
    Application.OnTime RunWhen3, "MAKRO3"
End Sub

Sub MAKRO()
    On Error Resume Next
    Application.ScreenUpdating = False
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Dash")
    Set lo = ws.ListObjects("Sorgu1")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    lo.Sort.SortFields.Add Key:=ws.Range("Sorgu1[[#All],[zaman]]"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With lo.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True
    AUTO_MAKRO
End Sub

Sub MAKRO2()
    On Error Resume Next
    Application.ScreenUpdating = False
    DoEvents
    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Misafir")
    Set wsDest = wb.Worksheets("Dash")
    Set lo = wsSource.ListObjects("Sorgu2")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear

    wsSource.Range("Sorgu2").Copy Destination:=wsDest.Range("H2")

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    AUTO_MAKRO2
End Sub

Sub MAKRO3()
    On Error Resume Next
    Application.ScreenUpdating = False
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Dışarda")
    Set lo = ws.ListObjects("Sorgu3")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    lo.Sort.SortFields.Add Key:=ws.Range("Sorgu3[[#All],[zaman]]"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With lo.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True
    AUTO_MAKRO3
End Sub

Sub MAKROSTOP()
    On Error Resume Next
    DoEvents
    Application.OnTime EarliestTime:=RunWhen1, Procedure:="MAKRO", Schedule:=False
    Application.OnTime EarliestTime:=RunWhen2, Procedure:="MAKRO2", Schedule:=False
    Application.OnTime EarliestTime:=RunWhen3, Procedure:="MAKRO3", Schedule:=False
End Sub

Sub TEMIZLE()
    On Error Resume Next
    Application.ScreenUpdating = False
    ThisWorkbook.Worksheets("Dash").Range("H2:O18").ClearContents
    Application.ScreenUpdating = True
End Sub
 
K

kaos64

Katılım
27 Ağustos 2009
Mesajlar
35
Excel Vers. ve Dili
Oficce 2016
Altın Üyelik Bitiş Tarihi
20-12-2024
teşekkür ederim tugkan bey

dogru mu dur

Sub AUTO_MAKRO()
On Error Resume Next
DoEvents
Application.OnTime Now + TimeValue("00:00:10"), "MAKRO"
End Sub
Sub AUTO_MAKRO2()
On Error Resume Next
DoEvents
Application.OnTime Now + TimeValue("00:01:00"), "MAKRO2"
End Sub
Sub AUTO_MAKRO3()
On Error Resume Next
DoEvents
Application.OnTime Now + TimeValue("00:01:00"), "MAKRO3"
End Sub
Sub MAKRO()
On Error Resume Next
DoEvents
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Dash")
Set lo = ws.ListObjects("Sorgu1")

lo.QueryTable.Refresh BackgroundQuery:=False

lo.Sort.SortFields.Clear
lo.Sort.SortFields.Add Key:=ws.Range("Sorgu1[[#All],[zaman]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With lo.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
AUTO_MAKRO
End Sub
Sub MAKRO2()
On Error Resume Next
DoEvents
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Misafir")
Set lo = ws.ListObjects("Sorgu2")

lo.QueryTable.Refresh BackgroundQuery:=False

lo.Sort.SortFields.Clear
wb.Sheets("Misafir").Range("Sorgu2").Copy
wb.Sheets("Dash").Range("H2:O2").PasteSpecial
AUTO_MAKRO2
End Sub
Sub MAKRO3()
On Error Resume Next
DoEvents
Dim wb As Workbook
Dim ws As Worksheet
Dim lo As ListObject

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Dışarda")
Set lo = ws.ListObjects("Sorgu3")

lo.QueryTable.Refresh BackgroundQuery:=False

lo.Sort.SortFields.Clear
lo.Sort.SortFields.Add Key:=ws.Range("Sorgu3[[#All],[zaman]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With lo.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
wb.Sheets("Dışarda").Range("Sorgu3").Sheets ("Dash")
AUTO_MAKRO3
End Sub
Sub MAKROSTOP()
On Error Resume Next
Application.OnTime TimeValue("00:00:10"), "MAKRO", , False
Application.OnTime TimeValue("00:01:00"), "MAKRO2", , False
Application.OnTime TimeValue("00:01:00"), "MAKRO3", , False
On Error GoTo 0
End Sub
Sub TEMIZLE()
On Error Resume Next
Range("H2:O30").Select
Selection.ClearContents
Range("A1").Select
End Sub
 
tugkan

tugkan

Altın Üye
Katılım
6 Kasım 2004
Mesajlar
481
Excel Vers. ve Dili
Excel 2016
Türkçe 64 BIT
Altın Üyelik Bitiş Tarihi
16-10-2025
Makro, üç farklı sorguyu periyodik olarak çalıştırıyor ve sonuçları sıralayıp "Dash" sayfasına yerleştiriyor. Ayrıca, bir MAKROSTOP makrosu ile işlemleri durduruyoruz. Aşağıdaki kodu uygulayıp sonucu paylaşır mısınız

Eksikler ve Düzeltmeler:
  • MAKRO3'te: Verilerin "Dışarda" sayfasından "Dash" sayfasına kopyalanması hatalı olabilir. Bu işlemi düzeltebiliriz.
  • MAKROSTOP fonksiyonunda, makroların doğru şekilde durması için makroların başlatıldığı zamana göre Application.OnTime ayarını kullanmanız gerekiyor.
  • wb.Sheets("Dışarda").Range("Sorgu3").Sheets ("Dash") ifadesi yanlış. Doğru şekilde kopyalama işlemi yapılmalıdır.
Düzeltilmiş Kod:

Kod: 
Sub AUTO_MAKRO()
    On Error Resume Next
    DoEvents
    Application.OnTime Now + TimeValue("00:00:10"), "MAKRO"
End Sub

Sub AUTO_MAKRO2()
    On Error Resume Next
    DoEvents
    Application.OnTime Now + TimeValue("00:01:00"), "MAKRO2"
End Sub

Sub AUTO_MAKRO3()
    On Error Resume Next
    DoEvents
    Application.OnTime Now + TimeValue("00:01:00"), "MAKRO3"
End Sub

Sub MAKRO()
    On Error Resume Next
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Dash")
    Set lo = ws.ListObjects("Sorgu1")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    lo.Sort.SortFields.Add Key:=ws.Range("Sorgu1[[#All],[zaman]]"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With lo.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    AUTO_MAKRO
End Sub

Sub MAKRO2()
    On Error Resume Next
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Misafir")
    Set lo = ws.ListObjects("Sorgu2")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    wb.Sheets("Misafir").Range("Sorgu2").Copy
    wb.Sheets("Dash").Range("H2:O2").PasteSpecial
    Application.CutCopyMode = False ' Kes kopya modunu devre dışı bırak
    
    AUTO_MAKRO2
End Sub

Sub MAKRO3()
    On Error Resume Next
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Dışarda")
    Set lo = ws.ListObjects("Sorgu3")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    lo.Sort.SortFields.Add Key:=ws.Range("Sorgu3[[#All],[zaman]]"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With lo.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' Verileri "Dışarda" sayfasından "Dash" sayfasına kopyala
    wb.Sheets("Dışarda").Range("Sorgu3").Copy
    wb.Sheets("Dash").Range("A1").PasteSpecial ' "Dash" sayfasına yapıştır
    Application.CutCopyMode = False ' Kes kopya modunu devre dışı bırak
    
    AUTO_MAKRO3
End Sub

Sub MAKROSTOP()
    On Error Resume Next
    Application.OnTime EarliestTime:=Now + TimeValue("00:00:10"), Procedure:="MAKRO", Schedule:=False
    Application.OnTime EarliestTime:=Now + TimeValue("00:01:00"), Procedure:="MAKRO2", Schedule:=False
    Application.OnTime EarliestTime:=Now + TimeValue("00:01:00"), Procedure:="MAKRO3", Schedule:=False
    On Error GoTo 0
End Sub

Sub TEMIZLE()
    On Error Resume Next
    Range("H2:O30").ClearContents
    Range("A1").Select
End Sub
Yaptığım Düzeltmeler:
  1. wb.Sheets("Dışarda").Range("Sorgu3").Sheets("Dash") ifadesini düzelterek verileri doğru şekilde "Dash" sayfasına kopyaladım.
  2. Kes-Kopya Modu: Kopyalama işleminden sonra Application.CutCopyMode = False ekleyerek, kopyalama modunu kapattım.
  3. OnTime Ayarları: MAKROSTOP makrosunda Now + TimeValue kullanarak zamanlanmış görevleri durdurmanız gerekti. Artık görevler durdurulacak.
  4. Kopyalama İşlemleri: MAKRO2 ve MAKRO3'te kopyalanan verilerin doğru alanlara yapıştırılmasını sağladım.
Bu düzeltmelerle birlikte makroların daha verimli çalışacağını göreceksiniz.
 
K

kaos64

Katılım
27 Ağustos 2009
Mesajlar
35
Excel Vers. ve Dili
Oficce 2016
Altın Üyelik Bitiş Tarihi
20-12-2024
pitchoute Bey Merhaba
sorgu2 de verdi
HRESULT özel durum döndürdü: 0x800A03EC
 
Son düzenleme:
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
324
Excel Vers. ve Dili
Excel 2021 Türkçe
Dener misiniz hocam;


Kod: 
Option Explicit

Dim RunWhen1 As Double
Dim RunWhen2 As Double
Dim RunWhen3 As Double

Sub AUTO_MAKRO()
    On Error Resume Next
    DoEvents
    RunWhen1 = Now + TimeValue("00:00:10")
    Application.OnTime RunWhen1, "MAKRO"
End Sub

Sub AUTO_MAKRO2()
    On Error Resume Next
    DoEvents
    RunWhen2 = Now + TimeValue("00:01:00")
    Application.OnTime RunWhen2, "MAKRO2"
End Sub

Sub AUTO_MAKRO3()
    On Error Resume Next
    DoEvents
    RunWhen3 = Now + TimeValue("00:01:00")
    Application.OnTime RunWhen3, "MAKRO3"
End Sub

Sub MAKRO()
    On Error Resume Next
    Application.ScreenUpdating = False
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Dash")
    Set lo = ws.ListObjects("Sorgu1")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    lo.Sort.SortFields.Add Key:=ws.Range("Sorgu1[[#All],[zaman]]"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With lo.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True
    AUTO_MAKRO
End Sub

Sub MAKRO2()
    On Error Resume Next
    Application.ScreenUpdating = False
    DoEvents
    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Misafir")
    Set wsDest = wb.Worksheets("Dash")
    Set lo = wsSource.ListObjects("Sorgu2")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear

    ' Kopyalama işlemi seçim yapmadan gerçekleştiriliyor
    wsSource.Range("Sorgu2").Copy
    wsDest.Range("H2").PasteSpecial xlPasteValuesAndNumberFormats

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    AUTO_MAKRO2
End Sub

Sub MAKRO3()
    On Error Resume Next
    Application.ScreenUpdating = False
    DoEvents
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Dışarda")
    Set lo = ws.ListObjects("Sorgu3")

    lo.QueryTable.Refresh BackgroundQuery:=False

    lo.Sort.SortFields.Clear
    lo.Sort.SortFields.Add Key:=ws.Range("Sorgu3[[#All],[zaman]]"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With lo.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True
    AUTO_MAKRO3
End Sub

Sub MAKROSTOP()
    On Error Resume Next
    DoEvents
    Application.OnTime EarliestTime:=RunWhen1, Procedure:="MAKRO", Schedule:=False
    Application.OnTime EarliestTime:=RunWhen2, Procedure:="MAKRO2", Schedule:=False
    Application.OnTime EarliestTime:=RunWhen3, Procedure:="MAKRO3", Schedule:=False
End Sub

Sub TEMIZLE()
    On Error Resume Next
    Application.ScreenUpdating = False
    ThisWorkbook.Worksheets("Dash").Range("H2:O18").ClearContents
    Application.ScreenUpdating = True
End Sub
 
K

kaos64

Katılım
27 Ağustos 2009
Mesajlar
35
Excel Vers. ve Dili
Oficce 2016
Altın Üyelik Bitiş Tarihi
20-12-2024
pitchoute Bey
Dash Ekranı sabit kalsa sorgular çalışınca sayfalar değişiyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst