Çözüldü İl merkezleri ve tüm ilçeleri getirme

[Excelismail]

Hayırlı günler.


Ek kısmına eklediğim çalışma sayfasında, bir ili seçtiğimizde örneğin İstanbul il merkezini hem de tüm ilçelerin aynı anda tabloya getirebilir mi?

 

[Excelismail]

Sağolun hocam.

 

[Refaz]

Şunu sorayım.Ramazan hep 30 gün oluyor biliyordum.Aklıma takılıp duruyordu bu araştırdım ve bazen 29 oluyormuş.
Ben kodda 30 güne göre ayarladım.29 olursa nasıl olacak?
Bunun cevabı kodda yanılmıyorsam 30 yazmıştım onu bir hücreyede bağlayabiliriz.Hücrede hangisi yazarsa ona göre sonuç gelebilir.
Bu 30 yada 29 için nasıl yapılabilinir?

 

[Refaz]

Şunu sorayım.Ramazan hep 30 gün oluyor biliyordum.Aklıma takılıp duruyordu bu araştırdım ve bazen 29 oluyormuş.
Ben kodda 30 güne göre ayarladım.29 olursa nasıl olacak?
Bunun cevabı kodda yanılmıyorsam 30 yazmıştım onu bir hücreyede bağlayabiliriz.Hücrede hangisi yazarsa ona göre sonuç gelebilir.
Bu 30 yada 29 için nasıl yapılabilinir?

Bu 29 ve 30 gün için aklıma bişey geldi.
Kodun en başında örnek adana için kod çalışır ve tablonun sondaki sayıyı alabiliriz.Mesela 30 Ramazan yazıyorsa 30 a göre 29 yazıyorsa 29 a göre.
Bugün tam düzenleyip dosya eklerim.

 

[Excelismail]

Hocam çok harika olur.

 

[Refaz]

Artık 29 da olsa 30 da olsa otomatiğe bağlattım ve for each ile yazılan gereksiz kodları değiştirdim abey.
Denersiniz.Kodlar altta bunu sizin ilçe eklediğiniz dosyaya uygularsınız.
Birde resimdeki gibi boyadığım gibi yaptım sayfa adlarını özelliklerden.

Private Const urLL As String = "https://ramazan.diyanet.gov.tr/tr-TR/Imsakiye/Imsakiye?ilId="


Private Function yirmidokuz_otuz() As Byte
    Dim kac As Long, ii As Integer, kes As Byte, bulAdet As Object, ilSec As String
    
    yirmidokuz_otuz = 0
    ilSec = imsakiye.Cells(2, "i").Value
    
    If Trim(ilSec) = "" Then
        MsgBox "il sec.", vbCritical, "Hata": Exit Function
    End If
    
    On Error Resume Next
    kac = WorksheetFunction.Match(ilSec, imsakiye.Range("V:V"), 0)
    If kac = 0 Then Exit Function
    On Error GoTo 0


    Web_URL = urLL & imsakiye.Range("u" & kac).Value & "&ilceId=" & imsakiye.Range("w" & kac).Value


    Set HTML_Content = CreateObject("htmlfile")
    
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", Web_URL, False
        .send
        HTML_Content.body.innerHTML = .responseText
    End With
  


   Set bulAdet = HTML_Content.getElementsByTagName("table")(0).getElementsByTagName("tr")
'       MsgBox bulAdet.Length
  
    For ii = 2 To bulAdet.Length 'Ramazan baslangicidan baslamak icin 2 yazildi
        kes = Val(Trim(Split(bulAdet(ii).innerText, "Ramazan")(0)))
        If kes = 29 Then
            yirmidokuz_otuz = kes
        ElseIf kes = 30 Then
            yirmidokuz_otuz = kes
            Exit For
        End If
    Next

End Function


Sub il_ilteleriAktar()


Dim syfVakitler As Worksheet, syfimsak As Worksheet, i As Long, x As Long, ii As Integer
Dim bul1 As Range, bul2 As Range, kac As Long, say As Long
Dim zaman As Date, tarih As Date, kes As Byte, adetSonuc As Byte, deger As String
Dim htm As Object


Set syfimsak = imsakiye 'imsakiye
Set syfVakitler = vakitler 'vakitler


If IsEmpty(syfimsak.Range("I2").Value) Then
    MsgBox "Lütfen il seçiniz."
    Exit Sub
End If


    
  adetSonuc = yirmidokuz_otuz
   If adetSonuc = 0 Then
     MsgBox "Hata var..", vbCritical, "Hata"
     Exit Sub
   End If


say = 0:


Set bul1 = syfimsak.Range("T:T").Find(syfimsak.Range("i2").Value, , , 1)
Set bul2 = syfimsak.Range("T:T").Find(syfimsak.Range("i2").Value, , , 1, xlRows, xlPrevious)


syfVakitler.Range("A2:D2").CurrentRegion.Offset(1).ClearContents


For i = bul1.Row To bul2.Row
    son = syfVakitler.Cells(Rows.Count, 1).End(3).Row + 1
    syfVakitler.Range("A" & son & ":A" & son + adetSonuc - 1) = syfimsak.Cells(i, "V").Value '-1 sebebi .Row + 1 den dolayi
Next


    Application.ScreenUpdating = False
    son = syfVakitler.Cells(Rows.Count, 1).End(3).Row
    ReDim arr(1 To 3, 1 To 1)
    
    
    For i = 2 To son Step adetSonuc + 1 '+1 demek 2 den basladigi icin
        On Error Resume Next
       kac = WorksheetFunction.Match(syfVakitler.Cells(i, 1).Value, syfimsak.Range("V:V"), 0)
        On Error GoTo 0
        If kac = 0 Then GoTo var
        Web_URL = urLL & syfimsak.Range("u" & kac).Value & "&ilceId=" & syfimsak.Range("w" & kac).Value
    
        Set HTML_Content = CreateObject("htmlfile")
        
        With CreateObject("msxml2.xmlhttp")
            .Open "GET", Web_URL, False
            .send
            HTML_Content.body.innerHTML = .responseText
        End With
                    
   Set bulAdet = HTML_Content.getElementsByTagName("table")(0).getElementsByTagName("tr")
'       MsgBox bulAdet.Length
  
    For ii = 2 To adetSonuc + 2 ' bulAdet.Length  'Ramazan baslangicidan baslamak icin 2 yazildi
       deger = ""
       On Error Resume Next
       deger = bulAdet(ii).getElementsByTagName("td")(1).innerText
       If deger = "" Then GoTo var1
        say = say + 1: ReDim Preserve arr(1 To 3, 1 To say)
        arr(1, say) = bulAdet(ii).getElementsByTagName("td")(1).innerText
        arr(2, say) = bulAdet(ii).getElementsByTagName("td")(2).innerText
        arr(3, say) = bulAdet(ii).getElementsByTagName("td")(6).innerText
var1:
    Next


var:
    Next
   On Error GoTo 0
   If say > 0 Then
          With syfVakitler
                For x = LBound(arr, 2) To UBound(arr, 2)
                    If Len(Trim(arr(1, x))) > 0 Then
                        tarih = CDate(Format(Mid(LTrim(RTrim(arr(1, x))), 1, InStrRev(LTrim(RTrim(arr(1, x))), " ") - 1), "dd.mm.yyyy"))
                        arr(1, x) = tarih * 1
                        
                        zaman = tarih & " " & Format(arr(2, x), "hh:mm")
                        arr(2, x) = zaman * 1
                        
                        zaman = tarih & " " & Format(arr(3, x), "hh:mm")
                        arr(3, x) = zaman * 1
                    End If
                Next x
Application.ScreenUpdating = True
              .Range("b2").Resize(UBound(arr, 2), 3).Value = WorksheetFunction.Transpose(arr)
              .Range("B2:B" & .Cells(Rows.Count, 1).End(3).Row).NumberFormat = " dd mmmm yyyy dddd"
              .Range("C2:D" & .Cells(Rows.Count, 1).End(3).Row).NumberFormat = "hh:mm"
          End With
   End If
    MsgBox "Ýþlem tamamlandý."


End Sub

 

[Excelismail]

Hocam seneye 29 sanırım oruç.

 

[Refaz]

Hocam seneye 29 sanırım oruç.

Artık dosyayı seneyede deneriz çalışıp çalışmayacağını
Ama önlemini aldık
Sizin imsak konu için internetten veri çekmeye merak saldım bu gidişle html,css gibileride öğreneceğim galiba

 

[Excelismail]

Düzenlediğiniz tablo çevrimiçi verileri alıyor. Sonrada ilçe eklediğim tabloya kopyala yapıştır yapıyorum. Hocam, ilçe eklediğim dosya local den çalıştığı için şart mı eklemem bu kodları? Ayrıca kodlar eklenecekse şuan için onları eklemem şuan beni aşar sanırım. Nasıl ekleyebilirim?

 

[Excelismail]

hocam ufaktan ufak, html ve css, javascipt bakıyorum.

 

[Refaz]

hocam ufaktan ufak, html ve css, javascipt bakıyorum.

Html ve css kolay gibi ama javascript zor galiba.
Bir sürüde proğramlama dil çıkartmışlar
Hangi birini öğreneceğiz bizde şaştık.