offic365 veri aktarma ve saydırma

B

bilisim2010

Altın Üye
Katılım
2 Nisan 2011
Mesajlar
68
Excel Vers. ve Dili
office 2007 tr
Altın Üyelik Bitiş Tarihi
17-12-2025
merhaba aşağıda verdiğim kod ile verilerim çok yavaş geliyor bu kodlarda nasıl bir değişiklik ile daha hızlı çekebilirim?


Private Sub CommandButton3_Click()
Dim kodSayfa As Worksheet
Dim hedefSayfa As Worksheet
Dim baslangicKod As String
Dim harfKisim As String
Dim rakamKisim As String
Dim satirKod As Range
Dim hedefSatir As Long
Dim i As Long
Dim tempKod As Double

Set kodSayfa = ThisWorkbook.Sheets("ALİS")
Set hedefSayfa = ThisWorkbook.Sheets("GENELKODLAR")
hedefSayfa.Columns("B").ClearContents
hedefSayfa.Columns("C").ClearContents
hedefSayfa.Columns("D").ClearContents

For Each satirKod In kodSayfa.Range("B2:B" & kodSayfa.Cells(kodSayfa.Rows.Count, "B").End(xlUp).Row)
If IsNumeric(satirKod.Value) And satirKod.Value <> "" Then
baslangicKod = satirKod.Value

hedefSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "B").End(xlUp).Row + 1

For i = 0 To 96
tempKod = CDbl(baslangicKod) + i
hedefSayfa.Cells(hedefSatir + i, "B").Value = Format(tempKod, "0")
Next i
End If
Next satirKod
End Sub
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
50
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
@bilisim2010 bu kodu dener misiniz.

Kod: 
Private Sub CommandButton3_Click()
    Dim kodSayfa As Worksheet
    Dim hedefSayfa As Worksheet
    Dim baslangicKod As String
    Dim harfKisim As String
    Dim rakamKisim As String
    Dim satirKod As Range
    Dim hedefSatir As Long
    Dim i As Long
    Dim tempKod As Double
    Dim kodArray() As Double
    Dim outputArray() As Variant
    Dim j As Long
    
    ' Sayfaları belirle
    Set kodSayfa = ThisWorkbook.Sheets("ALİS")
    Set hedefSayfa = ThisWorkbook.Sheets("GENELKODLAR")
    
    ' Gereksiz içerikleri temizle
    hedefSayfa.Columns("B").ClearContents
    hedefSayfa.Columns("C").ClearContents
    hedefSayfa.Columns("D").ClearContents
    
    ' Performans iyileştirmeleri
    Application.ScreenUpdating = False ' Ekran güncellemelerini devre dışı bırak
    Application.Calculation = xlCalculationManual ' Otomatik hesaplamayı devre dışı bırak
    Application.EnableEvents = False ' Olayları devre dışı bırak

    ' Verileri dizilere al ve işle
    For Each satirKod In kodSayfa.Range("B2:B" & kodSayfa.Cells(kodSayfa.Rows.Count, "B").End(xlUp).Row)
        If IsNumeric(satirKod.Value) And satirKod.Value <> "" Then
            baslangicKod = satirKod.Value
            hedefSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "B").End(xlUp).Row + 1
            
            ' Diziyi oluştur
            ReDim kodArray(96)
            For i = 0 To 96
                kodArray(i) = CDbl(baslangicKod) + i
            Next i
            
            ' Veriyi hedef sayfaya yerleştirmek için array kullan
            ReDim outputArray(1 To 96, 1 To 1)
            For i = 0 To 96
                outputArray(i + 1, 1) = Format(kodArray(i), "0")
            Next i
            
            ' Veriyi tek seferde yaz
            hedefSayfa.Range(hedefSayfa.Cells(hedefSatir, "B"), hedefSayfa.Cells(hedefSatir + 95, "B")).Value = outputArray
        End If
    Next satirKod

    ' Performans iyileştirmelerini geri al
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub
 
B

bilisim2010

Altın Üye
Katılım
2 Nisan 2011
Mesajlar
68
Excel Vers. ve Dili
office 2007 tr
Altın Üyelik Bitiş Tarihi
17-12-2025
volki_112' Alıntı:
@bilisim2010 bu kodu dener misiniz.

Kod: 
Private Sub CommandButton3_Click()
    Dim kodSayfa As Worksheet
    Dim hedefSayfa As Worksheet
    Dim baslangicKod As String
    Dim harfKisim As String
    Dim rakamKisim As String
    Dim satirKod As Range
    Dim hedefSatir As Long
    Dim i As Long
    Dim tempKod As Double
    Dim kodArray() As Double
    Dim outputArray() As Variant
    Dim j As Long
   
    ' Sayfaları belirle
    Set kodSayfa = ThisWorkbook.Sheets("ALİS")
    Set hedefSayfa = ThisWorkbook.Sheets("GENELKODLAR")
   
    ' Gereksiz içerikleri temizle
    hedefSayfa.Columns("B").ClearContents
    hedefSayfa.Columns("C").ClearContents
    hedefSayfa.Columns("D").ClearContents
   
    ' Performans iyileştirmeleri
    Application.ScreenUpdating = False ' Ekran güncellemelerini devre dışı bırak
    Application.Calculation = xlCalculationManual ' Otomatik hesaplamayı devre dışı bırak
    Application.EnableEvents = False ' Olayları devre dışı bırak

    ' Verileri dizilere al ve işle
    For Each satirKod In kodSayfa.Range("B2:B" & kodSayfa.Cells(kodSayfa.Rows.Count, "B").End(xlUp).Row)
        If IsNumeric(satirKod.Value) And satirKod.Value <> "" Then
            baslangicKod = satirKod.Value
            hedefSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "B").End(xlUp).Row + 1
           
            ' Diziyi oluştur
            ReDim kodArray(96)
            For i = 0 To 96
                kodArray(i) = CDbl(baslangicKod) + i
            Next i
           
            ' Veriyi hedef sayfaya yerleştirmek için array kullan
            ReDim outputArray(1 To 96, 1 To 1)
            For i = 0 To 96
                outputArray(i + 1, 1) = Format(kodArray(i), "0")
            Next i
           
            ' Veriyi tek seferde yaz
            hedefSayfa.Range(hedefSayfa.Cells(hedefSatir, "B"), hedefSayfa.Cells(hedefSatir + 95, "B")).Value = outputArray
        End If
    Next satirKod

    ' Performans iyileştirmelerini geri al
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...

outputArray(i + 1, 1) = Format(kodArray(i), "0")

hocam burada hata veriyor yanlız şöyleki bu kodlar Next satirKod dan sonra tekrar bir each var tamamını yazıyorum galiba benden kaynaklandı sorun kırmızıyla gönderdiğim kodlarda ilk yolladığımın devamı b2 de rakam c2 de metin d2 de rakam var hücrelerde.

Dim hedefSayfa As Worksheet
Dim baslangicKod As String
Dim harfKisim As String
Dim rakamKisim As String
Dim satirKod As Range
Dim hedefSatir As Long
Dim i As Long
Dim tempKod As Double
Dim kodArray() As Double
Dim outputArray() As Variant
Dim j As Long

' Sayfaları belirle
Set kodSayfa = ThisWorkbook.Sheets("ALİS")
Set hedefSayfa = ThisWorkbook.Sheets("GENELKODLAR")

' Gereksiz içerikleri temizle
hedefSayfa.Columns("B").ClearContents
hedefSayfa.Columns("C").ClearContents
hedefSayfa.Columns("D").ClearContents

' Performans iyileştirmeleri
Application.ScreenUpdating = False ' Ekran güncellemelerini devre dışı bırak
Application.Calculation = xlCalculationManual ' Otomatik hesaplamayı devre dışı bırak
Application.EnableEvents = False ' Olayları devre dışı bırak

' Verileri dizilere al ve işle
For Each satirKod In kodSayfa.Range("B2:B" & kodSayfa.Cells(kodSayfa.Rows.Count, "B").End(xlUp).Row)
If IsNumeric(satirKod.Value) And satirKod.Value <> "" Then
baslangicKod = satirKod.Value
hedefSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "B").End(xlUp).Row + 1

' Diziyi oluştur
ReDim kodArray(96)
For i = 0 To 96
kodArray(i) = CDbl(baslangicKod) + i
Next i

' Veriyi hedef sayfaya yerleştirmek için array kullan
ReDim outputArray(1 To 96, 1 To 1)
For i = 0 To 96
outputArray(i + 1, 1) = Format(kodArray(i), "0")
Next i

' Veriyi tek seferde yaz
hedefSayfa.Range(hedefSayfa.Cells(hedefSatir, "B"), hedefSayfa.Cells(hedefSatir + 95, "B")).Value = outputArray
End If
Next satirKod

For Each satirKod In kodSayfa.Range("C2:C" & kodSayfa.Cells(kodSayfa.Rows.Count, "C").End(xlUp).Row)
If satirKod.Value <> "" Then
baslangicKod = satirKod.Value

hedefSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "C").End(xlUp).Row + 1

For i = 0 To 96

hedefSayfa.Cells(hedefSatir + i, "C").Value = baslangicKod
Next i
End If
Next satirKod

For Each satirKod In kodSayfa.Range("D2:D" & kodSayfa.Cells(kodSayfa.Rows.Count, "D").End(xlUp).Row)
If IsNumeric(satirKod.Value) And satirKod.Value <> "" Then
baslangicKod = satirKod.Value

hedefSatir = hedefSayfa.Cells(hedefSayfa.Rows.Count, "D").End(xlUp).Row + 1

For i = 0 To 96

hedefSayfa.Cells(hedefSatir + i, "D").Value = baslangicKod
Next i
End If
Next satirKod
' Performans iyileştirmelerini geri al
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Kodlar başarıyla yazıldı!", vbInformation
Unload Me
UserForm1.Show
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst