Hata veren kod satırı

tahsinanarat · 15 Haziran 2018

Uzun süredir kullandığım aşağıdaki kod ile HTML dosyalarını excele aktarabiliyordum, pc sıfırlamasından sonra ekli resimlerde görüldüğü gibi hata mesajı vermektedir. Konu ile bilgisi olan arkadaşlardan yardım talep ediyorum.

Kod:

Sub bilgi_al()
    Dim URL As String
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim TDelements As IHTMLElementCollection
    Dim TDelement As HTMLTableCell
    Dim r As Long

    URL = dosyahtml
    Set IE = New InternetExplorer
    With IE
        .navigate URL
        .Visible = True
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
            Set HTMLdoc = .document
        End With
         
        Set TDelements = HTMLdoc.getElementsByTagName("TD")
         
        r = 0
        verial = False
        For Each TDelement In TDelements
            gecici = Trim(TDelement.innerText)
            If verial = False Then
                If gecici = "Fatura Saati:" Then verial = True
                If gecici = "Fatura Tarihi :" Then verial = True
                If gecici = "Sipariş Tarihi:" Then verial = True
                If gecici = "ERP Fatura No:" Then verial = True
                If gecici = "VKN / TCKN :" Then verial = True
                If gecici = "Toplam Iskonto" Then verial = True
                If gecici = "Net Toplam Tutar" Then verial = True
                If gecici = "KDV Matrahi (%18)" Then verial = True
                If gecici = "Genel Toplam" Then verial = True
                If gecici = "KDV Tutari (%18)" Then verial = True
                If gecici = "Fatura No:" Then verial = True
                If gecici = "Fatura No:" Then verial = True
                If gecici = "Vergi Dairesi:" Then verial = True
                If gecici = "Yaziyla Toplam Tutar" Then verial = True
                If gecici = "Tasima No:" Then verial = True
                GoTo son
            End If
            
            If verial Then
               r = r + 1
               Cells(satir, r).Value = TDelement.innerText
            End If
            verial = False
son:
        Next
    IE.Quit
    
End Sub

Necdet · 15 Haziran 2018

Merhaba,

Referanslardan biri yada bir kaçı eksiktir.
Ben deneme yanılma ile aşağıdaki referansları ekledim, çalışır hale geldi. fakat dosyahtml değeri boş olduğu için, bunu nereden alıyorsunuz bu kodların içinde yok. Belliki statik bir değer.

Microsoft WinHTTP Services, version ..
Microsoft HTML Object Libraryı
Microsoft Internet Controls

tahsinanarat · 16 Haziran 2018

Sn. Necdet hocam; referansları kontrol ettim, ilk sırada verdiğiniz referans yoktu ekledim, ancak sonuç değişmedi.

konuyu bu linkte
http://www.excel.web.tr/f48/html-den-excele-ilgili-hucreleri-cekmek-t167807.html
açmıştım, sn. asri bey yardımcı olmuştu, pc format atana kadar gayet güzel çalışıyordu.

Kod:

Dim dosyahtml As String
Dim satir, kalemsatir As Long

Sub menu()
   Call temizle
   Call dosya_listesi
   Call son_duzenleme
End Sub

Sub son_duzenleme()
    Sheets("Liste").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    Range("J2:N" & sonsatir).Select
    Selection.NumberFormat = "#,##0.00"
    
    Columns("J:N").Select
    Selection.Replace What:="TL", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("J" & sonsatir).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
    Range("J" & sonsatir).Select
    Selection.AutoFill Destination:=Range("J" & sonsatir & ":N" & sonsatir), Type:=xlFillDefault
    Range("J2:N" & sonsatir - 1).Select
     
     For Each hucre In Selection
         hucre.Value = 0 + hucre.Value
     Next
    Range("J2").Select
    
    
    Sheets("FaturaKalem").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
    Range("G2:H" & sonsatir).Select
    Selection.NumberFormat = "#,##0.00"
    Range("M2:M" & sonsatir).Select
    Selection.NumberFormat = "#,##0.00"
    
    Columns("G:M").Select
    Selection.Replace What:="TL", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("G:M").Select
    Selection.Replace What:=" TRY", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        
    Range("E" & sonsatir).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
    Range("H" & sonsatir).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
    Range("M" & sonsatir).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
    
    Range("G2:H" & sonsatir - 1, "M2:M" & sonsatir - 1).Select
     For Each hucre In Selection
         hucre.Value = 0 + hucre.Value
     Next
    Range("J2").Select
    
End Sub

Sub temizle()
        sonsatir = Cells(Rows.Count, "A").End(3).Row + 1
        If sonsatir = 1 Then sonsatir = 2
        Range("A2:Q" & sonsatir).ClearContents
End Sub

Sub dosya_listesi()
    yol = ActiveWorkbook.Path
    filtre = yol & "\*.html"
    dosya = Dir(filtre)
    satir = 1
    While dosya <> ""
       dosyahtml = yol & "\" & dosya
       satir = satir + 1
       Call bilgi_al
       dosya = Dir
    Wend

    kalemsatir = 2
    sonsatir = Sheets("FaturaKalem").Cells(Rows.Count, "A").End(3).Row
    If sonsatir = 1 Then sonsatir = 2
    Sheets("FaturaKalem").Range("A2:Q" & sonsatir).ClearContents
        
    dosya = Dir(filtre)
    While dosya <> ""
       dosyahtml = yol & "\" & dosya
       Call kalem_al
       dosya = Dir
    Wend
End Sub

Sub kalem_al()
    Dim URL As String
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim TDelements As IHTMLElementCollection
    Dim TDelement As HTMLTableCell
    Dim r As Long

    URL = dosyahtml
    Set IE = New InternetExplorer
    Set shkalem = Sheets("FaturaKalem")
    
    With IE
        .navigate URL
        .Visible = True
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
            Set HTMLdoc = .document
        End With
         
        Set TDelements = HTMLdoc.getElementsByTagName("TD")
         
        r = 0
        verial = False
        faturatarihial = False
        faturanoal = False
        For Each TDelement In TDelements
            gecici = Trim(TDelement.innerText)
            If gecici = "Fatura Tarihi :" And faturatarihial = False Then
               faturatarihial = True
               GoTo son
            End If
            If faturatarihial Then
              faturatarihi = gecici
              faturatarihial = False
            End If
            
            If gecici = "Fatura No:" And faturanoal = False Then
               faturanoal = True
               GoTo son
            End If
            
            If faturanoal Then
               faturanoal = False
               faturano = gecici
            End If
                
            If verial = False Then
                If InStr(gecici, "Net Tutar") > 0 Then
                   verial = True
                   GoTo son
                End If
            End If

                
            If verial Then
               If InStr(gecici, "Toplam Iskonto") > 0 Then GoTo bitti
               shkalem.Cells(kalemsatir, 1).Value = faturatarihi
               shkalem.Cells(kalemsatir, 2).Value = faturano
               
               r = r + 1
               shkalem.Cells(kalemsatir, r + 2).Value = TDelement.innerText
               If r Mod 11 = 0 Then
                 r = 0
                 kalemsatir = kalemsatir + 1
               End If
            End If
            'verial = False
son:
        Next
bitti:
     
    IE.Quit
    If shkalem.Cells(kalemsatir, 3) = "" Then
       shkalem.Cells(kalemsatir, 1).Clear
       shkalem.Cells(kalemsatir, 2).Clear
       
    End If
    
End Sub

Sub bilgi_al()
    Dim URL As String
    Dim IE As InternetExplorer
    Dim HTMLdoc As HTMLDocument
    Dim TDelements As IHTMLElementCollection
    Dim TDelement As HTMLTableCell
    Dim r As Long

    URL = dosyahtml
    Set IE = New InternetExplorer
    With IE
        .navigate URL
        .Visible = True
        While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
            Set HTMLdoc = .document
        End With
         
        Set TDelements = HTMLdoc.getElementsByTagName("TD")
         
        r = 0
        verial = False
        For Each TDelement In TDelements
            gecici = Trim(TDelement.innerText)
            If verial = False Then
                If gecici = "Fatura Saati:" Then verial = True
                If gecici = "Fatura Tarihi :" Then verial = True
                If gecici = "Sipariş Tarihi:" Then verial = True
                If gecici = "ERP Fatura No:" Then verial = True
                If gecici = "VKN / TCKN :" Then verial = True
                If gecici = "Toplam Iskonto" Then verial = True
                If gecici = "Net Toplam Tutar" Then verial = True
                If gecici = "KDV Matrahi (%18)" Then verial = True
                If gecici = "Genel Toplam" Then verial = True
                If gecici = "KDV Tutari (%18)" Then verial = True
                If gecici = "Fatura No:" Then verial = True
                If gecici = "Fatura No:" Then verial = True
                If gecici = "Vergi Dairesi:" Then verial = True
                If gecici = "Yaziyla Toplam Tutar" Then verial = True
                If gecici = "Tasima No:" Then verial = True
                GoTo son
            End If
            
            If verial Then
               r = r + 1
               Cells(satir, r).Value = TDelement.innerText
            End If
            verial = False
son:
        Next
    
    IE.Quit
    
End Sub

askm · 16 Haziran 2018

Sorununuz ya office güncelleme dosyaları ile ilgili ya da ie ayarları ile ilgili. Sanırım ie ayarları ile ilgili diye düşünüyorum. Benim bilgisayarımda ie 11 yüklü ve hiç bir işlem yapmadan direkt kodlar çalıştı. Eğer ie 11 yüklü ise güvenlik ayarlarını kontrol ediniz.

tahsinanarat · 17 Haziran 2018

Sn. askm, ofis 2016 kaldırdım, 2013 yükledim, sonuç aynı, güvenlik ayarlarında nereyi kontrol edeceğimi söyleyebilirmisiniz. Güvenlik seviyesi orta da.

halit3 · 17 Haziran 2018

Farklı bir uygulama dosya ile veri alınacak dosyalar aynı yerde olsun Form aç düğmesini tıkla
uerformda veri al düğmesine tıkla sonucu gözlemle

tahsinanarat · 17 Haziran 2018

Halit hocam ilginiz için çok teşekkür ederim, öncelikle sizin ve tüm excel üyelerinin bayramını kutlarım, formu açıp verileri al düğmesine bastığımda haraketlenme oluyor, alınacak dosyalar açılıyor, işlem tamam diyor ancak herhangi bir data almıyor, (aynı klasör içinde çalıştırdım) Ben bir eksik mi yaptım acaba.

halit3 · 17 Haziran 2018

Dasyaya bir de bunları ekledim pır pırlarda gitti

Application.ScreenUpdating
Application.DisplayAlerts

halit3 · 19 Haziran 2018

Birde bu kodu dene

Kod:

Sub dene()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Liste (ThisWorkbook.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "işlem tamam"

End Sub

Private Sub Liste(Klasor As String)
Dim fL As Object, f As Object, j As Long, ff As Object

Set fL = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next
uzanti = "html"

For Each Dosya In fL.GetFolder(Klasor).Files
deger5 = fL.GetExtensionName(Dosya)
If deger5 = uzanti Then
url1 = Dosya

Worksheets("veri").DrawingObjects.Delete
Worksheets("veri").Range("A1:z50000").ClearContents

Dim ie As InternetExplorerMedium
Set ie = New InternetExplorerMedium

ie.Visible = False
ie.Silent = True
ie.Navigate url1
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Worksheets("veri").Columns("A:P").UnMerge
Worksheets("veri").Columns("A:P").ClearContents

ie.ExecWB OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT
ie.ExecWB OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER
ie.ExecWB OLECMDID_CLEARSELECTION, OLECMDEXECOPT_DONTPROMPTUSER

Worksheets("veri").Range("a1").PasteSpecial
sat = Worksheets("data").Cells(Rows.Count, 1).End(3).Row + 1

ekle = 3
sut = 4
For k = 1 To 17
Worksheets("data").Cells(sat, k).Value = Worksheets("veri").Cells(k + ekle, sut).Value
If k = 9 Then ekle = 18: sut = sut - 1
Next k
ie.Quit

End If
Next

On Error GoTo sonraki
For Each ff In fL.GetFolder(Klasor).SubFolders
Liste (ff.Path)
sonraki:
Next

Set fL = Nothing
End Sub

tahsinanarat · 20 Haziran 2018

Sayın Halit hocam, öncelikle verdiğiniz cevaplar için çok teşekkür ederim, iki gündür bakım olduğundan forma girip cevap veremedim, kodlarınız çok güzel ve hızlı çalışıyor, özellikle son yazdığınız kod mükemmel hızlı, ancak: kalem sayısı fazla olan faturalar bulunmakta dolayısıyla fatura altı bilgilerde kaymalar meydana gelmertedir,
Fatura No:
Fatura Tarihi :
Fatura Saati:
ERP Fatura No:Fatura No:
Vergi Dairesi:VKN / TCKN :
Yukarıdaki data karşılıklarında herhangi bir sıkıntı yok, hep aynı hücreye denk gelmekteler;

Kalem sayısı fazla olduğunda ise aşağıdakilerin data karşılıkları gelmemektedir.
Toplam Iskonto
Net Toplam
TutarKDV Matrahi (%18)
KDV Tutari (%18)
Genel Toplam
Yaziyla Toplam Tutar

Bilgilerinize.

Yukarıdaki dataların karşılığını düşeyara formülü ile ayrı bir sayfaya getirip data sayfasına oradan yazdırabilirim.
Aynı mantık kodla olabirmi?
Kodlarınızdan faydalanarak formüllü sayfa ile yaptığım çalışma ektedir.

halit3 · 20 Haziran 2018

Tamam anladım
Data sayfasındaki başlıklardan araması iyi olurmu
BU KODU BİR DENE

Kod:

Sub dene()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("data").Range("A2:Q50000").ClearContents
Liste (ThisWorkbook.Path)

son = Worksheets("data").Cells(Rows.Count, 1).End(3).Row
Sheets("data").Cells(son + 1, 1).Value = "TOPLAM............................."
For t = 10 To 15
Sheets("data").Cells(son + 1, t).Value = WorksheetFunction.Sum(Worksheets("data").Range(Cells(2, t), Cells(son, t)))
Next t

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "işlem tamam"

End Sub

Private Sub Liste(Klasor As String)
Dim fL As Object, f As Object, j As Long, ff As Object

Set fL = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next
uzanti = "html"

For Each Dosya In fL.GetFolder(Klasor).Files
deger5 = fL.GetExtensionName(Dosya) ' uzantı buluyor
If deger5 = uzanti Then
url1 = Dosya



Dim ie As InternetExplorerMedium
Set ie = New InternetExplorerMedium

ie.Visible = False
ie.Silent = True
ie.Navigate url1
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop

Worksheets("veri").Columns("A:P").UnMerge
Worksheets("veri").Columns("A:P").ClearContents

ie.ExecWB OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT
ie.ExecWB OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER
ie.ExecWB OLECMDID_CLEARSELECTION, OLECMDEXECOPT_DONTPROMPTUSER

Worksheets("veri").Range("a1").PasteSpecial
sat = Worksheets("data").Cells(Rows.Count, 1).End(3).Row + 1

For i = 1 To 17
aranan1 = Trim(Worksheets("data").Cells(1, i).Value)


For Each X In Worksheets("veri").Range("C4:C20")
If aranan1 = Trim(X.Value) Then
Worksheets("data").Cells(sat, i).Value = Worksheets("veri").Cells(X.Row, X.Column + 1).Value
GoTo atla1
End If
Next X

atla1:
For Each k In Worksheets("veri").Range("b27:b40")
If aranan1 = Trim(k.Value) Then
Worksheets("data").Cells(sat, i).Value = Worksheets("veri").Cells(k.Row, k.Column + 1).Value
GoTo atla2
End If
Next k
atla2:
Next

ie.Quit

End If
Next

On Error GoTo sonraki
For Each ff In fL.GetFolder(Klasor).SubFolders
Liste (ff.Path)
sonraki:
Next

Set fL = Nothing
End Sub

tahsinanarat · 20 Haziran 2018

Halit Hocam elinize Beyninize sağlık, Bu daha da mükemmel oldu, Range("b27:b40") satırındaki b40'ı b100 yaptım hatasız olarak sonuçları getirdi,
Alttoplam için kod yazmışsınız, parasal sonuçlar hücreye rakam sonunda TL olarak geldiği için toplamlarını almadan hata veriyor, yani toplam almadan önce TL lerin kaldırılması gerekiyor,
Columns("h:l").Select
Selection.Replace What:="TL", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

şeklinde denedim ama, kodların neresine ekleyeceğimi bilemedim, gerçi bu pek bir sorun değil ama olursa daha iyi olur

Çok teşekkür ediyorum, sağolun.

halit3 · 20 Haziran 2018

ekli örnek dosyanızı irdeleyiniz.

tahsinanarat · 21 Haziran 2018

Sn. Halit hocam şimdi tam anlamıyla olması gerektiği gibi oldu, umarım çoğu arkadaşlarımın işine yarar, elinize emeğinize sağlık, sayenizde çok şey öğreneceğiz inşallah. Hakkınızı helal edin hocam.

halit3 · 21 Haziran 2018

tahsinanarat' Alıntı:
Sn. Halit hocam şimdi tam anlamıyla olması gerektiği gibi oldu, umarım çoğu arkadaşlarımın işine yarar, elinize emeğinize sağlık, sayenizde çok şey öğreneceğiz inşallah. Hakkınızı helal edin hocam.

Teşekkürler iyi çalışmalar

Hata veren kod satırı

tahsinanarat

Ekli dosyalar

Necdet

Moderatör

tahsinanarat

askm

Destek Ekibi

tahsinanarat

halit3

Uzman

Ekli dosyalar

tahsinanarat

halit3

Uzman

Ekli dosyalar

halit3

Uzman

tahsinanarat

Ekli dosyalar

halit3

Uzman

tahsinanarat

halit3

Uzman

Ekli dosyalar

tahsinanarat

halit3

Uzman