[Yardım]  KAN ŞEKERİ TAKİP ÇİZELGESİ

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#1)  msuphi » 30 Ekm 2018 09:56

Merhaba ekteki dosyada kaynakta varolan verileri çizelgede tarih ve saatine göre hücrelere nasıl yerleştirebilirim.Yardımlarınızı bekliyorum.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
msuphi
Yeni Başlamış
 
Adı Soyadı:mustafa suphi deniz
Kayıt: 28 Haz 2009 16:51
Konum: mersin
Meslek: Tekniker
Yaş: 4
İleti: 25
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: mersin

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#2)  msuphi » 05 Arl 2018 18:53

msuphi yazdı:Merhaba ekteki dosyada kaynakta varolan verileri çizelgede tarih ve saatine göre hücrelere nasıl yerleştirebilirim.Yardımlarınızı bekliyorum.


Değerli yardımlarınızı bekliyorum.
Kullanıcı avatarı
msuphi
Yeni Başlamış
 
Adı Soyadı:mustafa suphi deniz
Kayıt: 28 Haz 2009 16:51
Konum: mersin
Meslek: Tekniker
Yaş: 4
İleti: 25
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: mersin

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#3)  feraz » 06 Arl 2018 03:00

Makro ile yaptım bişeyler acaba olmuş mu?
Gece olayı için yapmadım.

Kod: Tümünü seç
Option Compare Text

Private Sub CommandButton1_Click()

Dim i As Integer, son As Long
Dim tabblo As Worksheet, j As Long

Set tabblo = Sheets("TABLO")

With Sheets("KAYNAK")
    tabblo.Range("C3:J" & Rows.Count) = ""
    son = tabblo.Cells(Rows.Count, "B").End(3).Row
   Application.ScreenUpdating = False
    For i = 3 To son Step 4
        For j = 2 To .Cells(Rows.Count, 1).End(3).Row
            If CLng(CDate(tabblo.Cells(i, 1))) = CLng(CDate(.Cells(j, 1))) Then
                If .Cells(j, "I").Value = tabblo.Range("C1").Value And .Cells(j, "J").Value = tabblo.Range("C2").Value Then
                    tabblo.Cells(i, "C").Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, "C").Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, "C").Value = .Cells(j, "E").Value
                End If
               
                If .Cells(j, "I").Value = tabblo.Range("C1").Value And .Cells(j, "J").Value = tabblo.Range("D2").Value Then
                    tabblo.Cells(i, "D").Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, "D").Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, "D").Value = .Cells(j, "E").Value
                End If
               
                If .Cells(j, "I").Value = tabblo.Range("E1").Value And .Cells(j, "J").Value = tabblo.Range("E2").Value Then
                    tabblo.Cells(i, "E").Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, "E").Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, "E").Value = .Cells(j, "E").Value
                End If
               
                If .Cells(j, "I").Value = tabblo.Range("E1").Value And .Cells(j, "J").Value = tabblo.Range("F2").Value Then
                    tabblo.Cells(i, "F").Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, "F").Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, "F").Value = .Cells(j, "E").Value
                End If
               
                If .Cells(j, "I").Value = tabblo.Range("G1").Value And .Cells(j, "J").Value = tabblo.Range("G2").Value Then
                    tabblo.Cells(i, "G").Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, "G").Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, "G").Value = .Cells(j, "E").Value
                End If
               
                If .Cells(j, "I").Value = tabblo.Range("G1").Value And .Cells(j, "J").Value = tabblo.Range("H2").Value Then
                    tabblo.Cells(i, "H").Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, "H").Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, "H").Value = .Cells(j, "E").Value
                End If
               
            End If
        Next
    Next
    Application.ScreenUpdating = True


End With
i = Empty: son = Empty: Set tabblo = Nothing

End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5531
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#4)  msuphi » 06 Arl 2018 11:16

Teşekkürler elinize sağlık.Gece olayını nasıl ekleriz.
Kullanıcı avatarı
msuphi
Yeni Başlamış
 
Adı Soyadı:mustafa suphi deniz
Kayıt: 28 Haz 2009 16:51
Konum: mersin
Meslek: Tekniker
Yaş: 4
İleti: 25
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: mersin

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#5)  feraz » 06 Arl 2018 12:30

Rica ederim mesajı görmeden tarih girince kodun çalışmasını yapmıştım bunuda ekleyeyim.
Gece için AÇ ve TOK olayı olmadığı için yapmamıştım dosyaya onuda ekleyip dosyayı yollarım yenisini.

Kod: Tümünü seç
Option Compare Text


Private Sub Worksheet_Change(ByVal Target As Range)

Dim tabblo As Worksheet
Dim bul As Range, adr As String

Set tabblo = Sheets("TABLO")

With Sheets("KAYNAK")

Application.ScreenUpdating = False
Application.EnableEvents = False
If Not Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then

    tabblo.Range(Range("C" & Target.Row), Range("J" & Target.Row + 3)) = ""
   
    Set bul = .Range("A:A").Find(What:=CDate(Target), LookIn:=xlFormulas, LookAt:=xlWhole)
 
  If Not bul Is Nothing Then
 
  adr = bul.Address
 
      Do
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("C1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("C2").Value Then
              tabblo.Cells(Target.Row, "C").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "C").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "C").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("C1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("D2").Value Then
              tabblo.Cells(Target.Row, "D").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "D").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "D").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("E1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("E2").Value Then
              tabblo.Cells(Target.Row, "E").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "E").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "E").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("E1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("F2").Value Then
              tabblo.Cells(Target.Row, "F").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "F").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "F").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("G1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("G2").Value Then
              tabblo.Cells(Target.Row, "G").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "G").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "G").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("G1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("H2").Value Then
              tabblo.Cells(Target.Row, "H").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "H").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "H").Value = .Cells(bul.Row, "E").Value
          End If
        Set bul = .Range("A:A").FindNext(bul)
                   
                   
     Loop While Not bul Is Nothing And bul.Address <> adr
 
  End If
   
End If

Set bul = Nothing: adr = vbNullString

   Application.EnableEvents = True
    Application.ScreenUpdating = True


End With


End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5531
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#6)  feraz » 06 Arl 2018 12:39

TABLO sayfasında A sütunlarına tarih yazınca kod çalışır.

Kod: Tümünü seç
Option Compare Text


Private Sub Worksheet_Change(ByVal Target As Range)

Dim tabblo As Worksheet
Dim bul As Range, adr As String

Set tabblo = Sheets("TABLO")

With Sheets("KAYNAK")

Application.ScreenUpdating = False
Application.EnableEvents = False
If Not Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then

    tabblo.Range(Range("C" & Target.Row), Range("J" & Target.Row + 3)) = ""
   
    Set bul = .Range("A:A").Find(What:=CDate(Target), LookIn:=xlFormulas, LookAt:=xlWhole)
 
  If Not bul Is Nothing Then
 
  adr = bul.Address
 
      Do
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("C1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("C2").Value Then
              tabblo.Cells(Target.Row, "C").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "C").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "C").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("C1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("D2").Value Then
              tabblo.Cells(Target.Row, "D").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "D").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "D").Value = .Cells(bul.Row, "E").Value
          End If
'---------------------
          If .Cells(bul.Row, "I").Value = tabblo.Range("E1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("E2").Value Then
              tabblo.Cells(Target.Row, "E").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "E").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "E").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("E1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("F2").Value Then
              tabblo.Cells(Target.Row, "F").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "F").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "F").Value = .Cells(bul.Row, "E").Value
          End If
'---------------------
          If .Cells(bul.Row, "I").Value = tabblo.Range("G1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("G2").Value Then
              tabblo.Cells(Target.Row, "G").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "G").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "G").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("G1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("H2").Value Then
              tabblo.Cells(Target.Row, "H").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "H").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "H").Value = .Cells(bul.Row, "E").Value
          End If
'---------------------
          If .Cells(bul.Row, "I").Value = tabblo.Range("I1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("I2").Value Then
              tabblo.Cells(Target.Row, "I").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "I").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "I").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("I1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("J2").Value Then
              tabblo.Cells(Target.Row, "J").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "J").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "J").Value = .Cells(bul.Row, "E").Value
          End If
         
        Set bul = .Range("A:A").FindNext(bul)
                   
                   
     Loop While Not bul Is Nothing And bul.Address <> adr
 
  End If
   
End If

Set bul = Nothing: adr = vbNullString

   Application.EnableEvents = True
    Application.ScreenUpdating = True


End With


End Sub

Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5531
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#7)  veyselemre » 06 Arl 2018 12:47

Kod: Tümünü seç
Option Base 1
Sub test()
    Set shK = Sheets("KAYNAK")
    Set shT = Sheets("TABLO")
    Set dic = CreateObject("Scripting.Dictionary")
   
    veriler = shK.Range("a2:J" & shK.Cells(Rows.Count, 1).End(3).Row).Value

    Dim w(4, 7)
    With dic
        For i = 1 To UBound(veriler)
            ky = veriler(i, 1)

            If Not .exists(ky) Then .Add ky, w

            Z = .Item(ky)
            Select Case veriler(i, 9) & "|" & veriler(i, 10)
            Case "Sabah|AÇ": sira = 1
            Case "Sabah|TOK": sira = 2
            Case "Öğlen|AÇ": sira = 3
            Case "Öğlen|TOK": sira = 4
            Case "Akşam|AÇ": sira = 5
            Case "Akşam|TOK": sira = 6
            Case "Gece|AÇ": sira = 7
            Case Else
                MsgBox i & ". satırdaki veri tanımlanamadı.."
                Exit Sub
            End Select
            Z(1, sira) = veriler(i, 2)
            Z(2, sira) = veriler(i, 3)
            Z(3, sira) = veriler(i, 5)
            .Item(ky) = Z
        Next i
        itms = .items
        kys = .keys
    End With

    shT.Range("A3:A6,C3:L6").ClearContents
    shT.Range("7:" & Rows.Count).Delete

    atla = 7
    For i = 0 To UBound(kys) - 1
        shT.Range("3:6").Copy shT.Cells(atla, 1)
        atla = atla + 4
    Next i

    atla = 3
    For i = 0 To UBound(kys)
        shT.Cells(atla, 1) = kys(i)
        shT.Cells(atla, 3).Resize(4, 7).Value = itms(i)
        atla = atla + 4
    Next i

    Set dic = Nothing
    Set shK = Nothing
    Set shT = Nothing

End Sub
Kullanıcı avatarı
veyselemre
Siteye Alışmış
 
Kayıt: 28 Nis 2015 17:53
Meslek: SERBEST
Yaş: 103
İleti: 235
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çubuk

Cevap: Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#8)  msuphi » 06 Arl 2018 18:39

feraz yazdı:TABLO sayfasında A sütunlarına tarih yazınca kod çalışır.

Kod: Tümünü seç
Option Compare Text


Private Sub Worksheet_Change(ByVal Target As Range)

Dim tabblo As Worksheet
Dim bul As Range, adr As String

Set tabblo = Sheets("TABLO")

With Sheets("KAYNAK")

Application.ScreenUpdating = False
Application.EnableEvents = False
If Not Intersect(Target, Range("A3:A" & Rows.Count)) Is Nothing Then

    tabblo.Range(Range("C" & Target.Row), Range("J" & Target.Row + 3)) = ""
   
    Set bul = .Range("A:A").Find(What:=CDate(Target), LookIn:=xlFormulas, LookAt:=xlWhole)
 
  If Not bul Is Nothing Then
 
  adr = bul.Address
 
      Do
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("C1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("C2").Value Then
              tabblo.Cells(Target.Row, "C").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "C").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "C").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("C1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("D2").Value Then
              tabblo.Cells(Target.Row, "D").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "D").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "D").Value = .Cells(bul.Row, "E").Value
          End If
'---------------------
          If .Cells(bul.Row, "I").Value = tabblo.Range("E1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("E2").Value Then
              tabblo.Cells(Target.Row, "E").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "E").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "E").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("E1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("F2").Value Then
              tabblo.Cells(Target.Row, "F").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "F").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "F").Value = .Cells(bul.Row, "E").Value
          End If
'---------------------
          If .Cells(bul.Row, "I").Value = tabblo.Range("G1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("G2").Value Then
              tabblo.Cells(Target.Row, "G").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "G").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "G").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("G1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("H2").Value Then
              tabblo.Cells(Target.Row, "H").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "H").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "H").Value = .Cells(bul.Row, "E").Value
          End If
'---------------------
          If .Cells(bul.Row, "I").Value = tabblo.Range("I1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("I2").Value Then
              tabblo.Cells(Target.Row, "I").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "I").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "I").Value = .Cells(bul.Row, "E").Value
          End If
   
          If .Cells(bul.Row, "I").Value = tabblo.Range("I1").Value And .Cells(bul.Row, "J").Value = tabblo.Range("J2").Value Then
              tabblo.Cells(Target.Row, "J").Value = Format(.Cells(bul.Row, "B").Value, "hh:mm:ss")
              tabblo.Cells(Target.Row + 1, "J").Value = .Cells(bul.Row, "C").Value
              tabblo.Cells(Target.Row + 2, "J").Value = .Cells(bul.Row, "E").Value
          End If
         
        Set bul = .Range("A:A").FindNext(bul)
                   
                   
     Loop While Not bul Is Nothing And bul.Address <> adr
 
  End If
   
End If

Set bul = Nothing: adr = vbNullString

   Application.EnableEvents = True
    Application.ScreenUpdating = True


End With


End Sub







Tarih kısmını sildiğimde aşağıdaki satır çalışma hatası veriyor.

Set bul = .Range("A:A").Find(What:=CDate(Target), LookIn:=xlFormulas, LookAt:=xlWhole)

Acaba tarihi kaynak sekmesinden alıp otomatik sıralayabilirmi.Elle yazmak biraz uzun sürüyor malum son 30 günlük tarihi yazmam gerekiyor.Ben kaynak verilerini bir android uygulamasından csv formatında bilgisayarıma gönderip oradan yapıştırıyorum.Teşekkür ederim.
Kullanıcı avatarı
msuphi
Yeni Başlamış
 
Adı Soyadı:mustafa suphi deniz
Kayıt: 28 Haz 2009 16:51
Konum: mersin
Meslek: Tekniker
Yaş: 4
İleti: 25
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: mersin

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#9)  feraz » 06 Arl 2018 19:23

Tamam akşam hallederim inşAalh.
Bir önceki döngü ile olanı ekleyip tarihleri otomatik yazdırabilirim.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5531
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#10)  feraz » 07 Arl 2018 00:28

Kodları yazdım deneyebilirsiniz.
Yapmanız gereken sadece Butona basmak TABLO sayfasındaki.

Not:verler adında bir sayfa ekledim tarihleri sıralayıp teke düşürmek için ve kolaylık olsun diye.Bu sayfa silinmemeli gizleyebilirsiniz.

Kod: Tümünü seç
Option Compare Text

Dim tabblo As Worksheet
Dim verlerr As Worksheet
Dim kayynak As Worksheet


Sub brlstr()

Dim i As Integer
Dim say As Integer

Set tabblo = Sheets("TABLO")
Set verlerr = Sheets("verler")

say = 3

With tabblo
    .Range("A3:B" & Rows.Count).UnMerge
    .Range("K3:L" & Rows.Count).UnMerge
    .Range("A3:B" & Rows.Count) = ""
    .Range("A1:L" & Rows.Count).Borders.LineStyle = 0
   
Application.ScreenUpdating = False
    For i = 1 To verlerr.Range("A" & Rows.Count).End(3).Row
         verlerr.Range("D1:D4").Copy
        .Cells(say, "B").PasteSpecial Paste:=xlPasteValues
        .Cells(say, "A").Value = Format(verlerr.Cells(i, "A").Value, "dd.mm.yyyy")
        .Range(.Cells(say, "A"), .Cells(say + 3, "A")).Merge
        .Range(.Cells(say, "K"), .Cells(say + 3, "L")).Merge
        say = say + 4
    Next
    verlerr.Range("A:A").Value = ""
    .Range("A1:L" & tabblo.Cells(Rows.Count, "B").End(3).Row).Borders.LineStyle = 1
Application.ScreenUpdating = True

End With

End Sub


Kod: Tümünü seç
Sub srla_Tek()

Dim son As Integer
Set verlerr = Sheets("verler")
Set kayynak = Sheets("KAYNAK")

Application.ScreenUpdating = False
With verlerr
     .Range("A:A") = ""
     son = kayynak.Range("A" & Rows.Count).End(3).Row
     kayynak.Range("A2:A" & son).Copy
    .Range("A1").PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
     son = .Range("A" & Rows.Count).End(3).Row
    .Range("A1:A" & son).Sort .Range("A1")
    .Range("$A$1:$A$" & son).RemoveDuplicates Columns:=1, Header:=xlNo

End With
Application.ScreenUpdating = True
son = Empty
End Sub



Kod: Tümünü seç
Private Sub CommandButton1_Click()

Dim i As Integer, son As Long
Dim j As Long
Dim arr1()
Dim ar2(), ar3()
Set tabblo = Sheets("TABLO")

With Sheets("KAYNAK")
    tabblo.Range("C3:J" & Rows.Count) = ""

    If WorksheetFunction.CountA(.Range("A2:A" & Rows.Count)) = 0 Then Exit Sub
   
    arr1 = Array("C1", "C1", "E1", "E1", "G1", "G1", "I1", "J1")
    arr2 = Array("C2", "D2", "E2", "F2", "G2", "H2", "I2", "J2")
    arr3 = Array("C", "D", "E", "F", "G", "H", "I", "J")
   
   Application.ScreenUpdating = False
   
   Call srla_Tek
   Call brlstr
   
   son = tabblo.Cells(Rows.Count, "B").End(3).Row
   
    For i = 3 To son Step 4
        For j = 2 To .Cells(Rows.Count, 1).End(3).Row
          For k = LBound(arr1) To UBound(arr1)
            If CLng(CDate(tabblo.Cells(i, 1))) = CLng(CDate(.Cells(j, 1))) Then
                If .Cells(j, "I").Value = tabblo.Range(arr1(k)).Value And .Cells(j, "J").Value = tabblo.Range(arr2(k)).Value Then
                    tabblo.Cells(i, arr3(k)).Value = Format(.Cells(j, "B").Value, "hh:mm:ss")
                    tabblo.Cells(i + 1, arr3(k)).Value = .Cells(j, "C").Value
                    tabblo.Cells(i + 2, arr3(k)).Value = .Cells(j, "E").Value
                End If
            End If
            Next
       Next
    Next
    Application.ScreenUpdating = True

MsgBox "TAMAMLANDI...", vbInformation, "BiTTi"
End With
Erase arr1: Erase arr2: Erase arr3
Set tabblo = Nothing: Set verlerr = Nothing: Set kayynak = Nothing
End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5531
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#11)  msuphi » 10 Arl 2018 09:47

Teşekkür ederim.Şu an için çalışıyor.
Kullanıcı avatarı
msuphi
Yeni Başlamış
 
Adı Soyadı:mustafa suphi deniz
Kayıt: 28 Haz 2009 16:51
Konum: mersin
Meslek: Tekniker
Yaş: 4
İleti: 25
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: mersin

Cevap: KAN ŞEKERİ TAKİP ÇİZELGESİ

İleti#12)  feraz » 10 Arl 2018 13:42

Rica ederim,kolay gelsin.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 19:36
Konum: Almanya
Meslek: İşçi
Yaş: 39
İleti: 5531
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 3 misafir

cron
Bumerang - Yazarkafe