- Katılım
- 4 Eylül 2020
- Mesajlar
- 394
- Excel Vers. ve Dili
- Excel 2016
- Altın Üyelik Bitiş Tarihi
- 22-11-2022
Merhaba aşağıdaki kod diğer sayfadan veri çekerken hücre içeriğinde ' tırnak varsa
Böyle hata vermektedir. Yardımcı olursanız sevinirim
Böyle hata vermektedir. Yardımcı olursanız sevinirim
Kod:
Option Explicit
Sub Analiz()
Dim S1 As Worksheet, S2 As Worksheet, Baglanti As Object
Dim Kayit_Seti As Object, Sorgu As String, Veri_Seti As Object
Dim Urun_Grubu As Variant, Satir As Long, Baslik As Variant
Dim Sutun As Byte, Say As Long, Zaman As Double
Zaman = Timer
Application.ScreenUpdating = False
Set S1 = Sheets("Sube_Hareketleri")
Set S2 = Sheets("Sayfa1")
Set Baglanti = CreateObject("AdoDb.Connection")
Set Kayit_Seti = CreateObject("AdoDb.RecordSet")
Set Veri_Seti = CreateObject("AdoDb.RecordSet")
S2.Cells.Delete
Satir = 3
Sutun = 1
Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
Sorgu = "Select [MALINCINSI] From [" & S1.Name & "$] Where [MALINCINSI] <> '' Group By [MALINCINSI]"
Kayit_Seti.Open Sorgu, Baglanti, 1, 1
If Kayit_Seti.RecordCount > 0 Then
S2.Cells(1, 15) = Now()
S2.Cells(1, 15).Font.Bold = True
For Each Urun_Grubu In Kayit_Seti.GetRows
Sorgu = "Select * From [" & S1.Name & "$] Where [MALINCINSI] = '" & Urun_Grubu & "' Order By [DEPO] Asc"
Veri_Seti.Open Sorgu, Baglanti, 1, 1
If Veri_Seti.RecordCount > 0 Then
Say = Veri_Seti.RecordCount
With S2.Cells(Satir - 1, 1)
.Font.Bold = True
.Interior.Color = 14277081
.Value = Urun_Grubu
.Resize(, 15).MergeCells = True
'.HorizontalAlignment = xlCenter
End With
For Each Baslik In Veri_Seti.Fields
S2.Cells(Satir, Sutun) = Baslik.Name
Sutun = Sutun + 1
Next
S2.Range("A" & Satir & ":I" & Satir).Font.Bold = True
S2.Cells(Satir + 1, 1).End(3)(2, 1).CopyFromRecordset Veri_Seti
Satir = Satir + Say + 4
Sutun = 1
End If
If Veri_Seti.State <> 0 Then Veri_Seti.Close
Next
End If
If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
If Baglanti.State <> 0 Then Baglanti.Close
S2.Range("A:I").ColumnWidth = 255
S2.Rows.AutoFit
S2.Columns.AutoFit
Set S1 = Nothing
Set S2 = Nothing
Set Baglanti = Nothing
Set Kayit_Seti = Nothing
Set Veri_Seti = Nothing
Application.ScreenUpdating = True
MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Ekli dosyalar
-
22.7 KB Görüntüleme: 7