Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Haziran 2006 Salı

Data Rate and Group Names and Group Opened a New Page.




'Module1

Option Explicit
Dim Sayfa As Worksheet
Dim Hücre As Range
Dim SonSayfa As Worksheet
Dim Alan As Range
Dim Satır As Variant

Sub VerileriKendiİsmindekiSayfalaraAktar()
On Error Resume Next
Application.DisplayAlerts = False
ActiveSheet.Move Before:=Sheets(1)
Application.DisplayAlerts = True
ActiveSheet.Copy After:=Sheets(Worksheets.Count)
Durak:
If [A2] = "" Then Exit Sub
Set Sayfa = ActiveSheet
Columns("A:D").EntireColumn.AutoFit
Sayfa.Name = [A2]
Set Hücre = [A2].CurrentRegion.Columns(1).ColumnDifferences([A2])
Set Hücre = Application.Intersect(Hücre.EntireRow, [A:D])
If Hücre.Address = "" Then Exit Sub
Worksheets.Add After:=Sheets(Worksheets.Count)
Set SonSayfa = Sheets(Worksheets.Count)
Sheets(SonSayfa.Name).Tab.ColorIndex = (Worksheets.Count - 1)
Sayfa.Select
For Each Alan In Hücre.Areas
Alan.Copy
Satır = SonSayfa.[a65536].End(3).Row + 1
SonSayfa.Cells(Satır, 1).Insert shift:=xlDown
Alan.Delete shift:=xlUp
Next
Set Hücre = Nothing
SonSayfa.Select
GoTo Durak
End Sub

10 Haziran 2006 Cumartesi

TreeView Control


'UserForm1

'A) Registre Reference List
    'Name: VBA, Description: Visual Basic For Applications, Full Path: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
    'Name: Excel, Description: Microsoft Excel 14.0 Object Library, Full Path: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
    'Name: stdole, Description: OLE Automation, Full Path: C:\Windows\SysWOW64\stdole2.tlb
    'Name: Office, Description: Microsoft Office 14.0 Object Library, Full Path: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
    'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, Full Path: C:\Windows\SysWOW64\FM20.DLL
    'Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), Full Path: C:\Windows\SysWow64\MSCOMCTL.OCX
'B) Additional Tools on UserForm1
    'ImageList1
    'Image1 , Label1, Label2
    'TreeView1
    'Label3 , Label4, Label5, Label6, Label7
    'TextBox1 , TextBox2, TextBox3, TextBox4
    'ComboBox1 , CommandButton1
'C) ImageList1 Custom
    'General; 16 * 16, UseMaskColor is checked
    'Images; To select images to be used in the nodes of TreeView1 "InsertPicture" use the button.

Option Explicit
Private i As Long, j As Long, k As Long
Private hNode As Variant
Private hParent As Variant
Private hMatch() As Variant
Private hObservation As Variant
Private hRecord As Variant
Private hLooked As Variant
Private hSlide As node
Private hCurrent As Boolean
Private hNodeList(1 To 1, 1 To 4)
Private hRow As Range
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] Treeview Control..."
    Call Ekran_Kur
    Call Sayfa_Kur
    Call Make_TreeView
End Sub
Private Sub TreeView1_NodeClick(ByVal node As MSComctlLib.node)

    On Error Resume Next
    TextBox1.Text = node.Text
    Call Read_Node_Data(node.Text)
    ComboBox1.Value = hNodeList(1, 1)
    TextBox2.Text = hNodeList(1, 2)
    TextBox3.Text = hNodeList(1, 3)
    TextBox4.Text = hNodeList(1, 4)
End Sub
Private Sub CommandButton1_Click()

    On Error GoTo Hata
    If (TextBox1.Value <> "") And (ComboBox1.Value <> "") Then
        Set hRow = Sheets(1).Columns(1).Find(TextBox1.Text, lookat:=xlWhole)
        If hRow Is Nothing Then
        Else
            hRow.Offset(, 1) = ComboBox1.Value
            'Call Resimlendir
            Call Make_TreeView
        End If
        With TreeView1.Nodes(TextBox1.Text)
            .Selected = True
            .EnsureVisible
        End With
    End If
Hata:
End Sub
Sub Make_TreeView() 'Ağaç Kur

    On Error Resume Next
    i = 0
    j = 0
    k = 0
    ComboBox1.Clear
    TreeView1.Nodes.Clear
    With Sheets("Veriler").Range(Sheets("Veriler").[A2], Sheets("Veriler").[A65536].End(xlUp))
        hNode = .Value
        hParent = .Offset(, 1).Value
    End With
    ReDim hMatch(1 To UBound(hNode), 1 To 1)
    For Each hRecord In hParent
        i = i + 1
        hLooked = Application.Match(hRecord, hNode, 0)
        If IsError(hLooked) Then
            hMatch(i, 1) = hNode(i, 1)
        Else
            j = 3
            ReDim Preserve hMatch(1 To UBound(hMatch), 1 To j)
            hMatch(i, 1) = hNode(i, 1)
            hMatch(i, 2) = hRecord
            hMatch(i, 3) = hParent(hLooked, 1)
            Do
                hLooked = Application.Match(hParent(hLooked, 1), hNode, 0)
                If IsError(hLooked) Then Exit Do
                If hParent(hLooked, 1) = "" Then Exit Do
                j = j + 1
                ReDim Preserve hMatch(1 To UBound(hMatch), 1 To j)
                hMatch(i, j) = hParent(hLooked, 1)
            Loop
        End If
    Next hRecord
    hObservation = Make_Matching(hMatch)
    For i = 1 To UBound(hObservation)
        For j = 1 To UBound(hObservation, 2)
            If Not IsEmpty(hObservation(i, j)) Then
                With TreeView1
                    hCurrent = False
                    For Each hRecord In .Nodes
                        If hRecord = hObservation(i, j) Then hCurrent = True
                    Next hRecord
                    If Not hCurrent Then
                        If j = 1 Then
                            'Image & SelectedImage; nothing...
                            Set hSlide = .Nodes.Add(, , hObservation(i, j), hObservation(i, j))
                            'Image & SelectedImage; ImageList1 \ ListImages \ Index...
                            'Set hSlide = .Nodes.Add(, , hObservation(i, j), hObservation(i, j), 2, 3)
                            'Image & SelectedImage; ImageList1 \ ListImages \ Key...
                            'Set hSlide = .Nodes.Add(, , hObservation(i, j), hObservation(i, j), "Resim2", "Resim3")

                        Else
                            'Image & SelectedImage; nothing...
                            Set hSlide = .Nodes.Add(hObservation(i, j - 1), tvwChild, hObservation(i, j), hObservation(i, j))
                            'Image & SelectedImage; ImageList1 \ ListImages \ Index...
                            'Set hSlide = .Nodes.Add(hObservation(i, j - 1), tvwChild, hObservation(i, j), hObservation(i, j), 2, 3)
                            'Image & SelectedImage; ImageList1 \ ListImages \ Key...
                            'Set hSlide = .Nodes.Add(hObservation(i, j - 1), tvwChild, hObservation(i, j), hObservation(i, j), "Resim2", "Resim3")

                        End If
                        hSlide.Expanded = True
                    End If
                End With
            End If
        Next j
    Next i
    ComboBox1.AddItem ""
    For Each hSlide In TreeView1.Nodes
        If hSlide.Children > 0 Then hSlide.ForeColor = vbBlack: hSlide.Bold = True
        If hSlide.Children = 0 Then hSlide.ForeColor = vbBlue: hSlide.Bold = False
        ComboBox1.AddItem hSlide.Text
    Next hSlide
End Sub
Function Make_Matching(ByVal Bellek As Variant) As Variant 'Eşleştir

    On Error GoTo Hata
    ReDim hObservation(LBound(Bellek) To UBound(Bellek), LBound(Bellek, 2) To UBound(Bellek, 2))
    For i = 1 To UBound(Bellek)
        k = 0
        For j = UBound(Bellek, 2) To 1 Step -1
            If Not IsEmpty(Bellek(i, j)) Then
                k = k + 1
                hObservation(i, k) = Bellek(i, j)
            End If
        Next j
    Next i
    Make_Matching = hObservation
Hata:
End Function
Function Read_Node_Data(DalAdı) As String 'Dal Bilgisi Oku

    On Error GoTo Hata
    Set hRow = Sheets(1).Columns(1).Find(DalAdı, lookat:=xlWhole)
    If hRow Is Nothing Then
        hNodeList(1, 1) = "None"
        hNodeList(1, 2) = "None"
        hNodeList(1, 3) = "None"
        hNodeList(1, 4) = "None"
    Else
        hNodeList(1, 1) = hRow.Offset(, 1).Value
        hNodeList(1, 2) = hRow.Offset(, 2).Value
        hNodeList(1, 3) = hRow.Offset(, 3).Value
        hNodeList(1, 4) = hRow.Offset(, 4).Value
    End If
Hata:
End Function
Private Sub Ekran_Kur()

    On Error Resume Next
    Dim Resim
    Set Resim = ImageList1.ListImages
    With Me
        .BackColor = VBA.RGB(242, 242, 242)
        .Width = 396
        .Height = 268
        With Image1
            .Left = 6
            .Top = 6
            .Height = 24
            .Width = 24
            .BorderColor = vbBlue
            .Picture = Resim(1).Picture
            .PictureAlignment = fmPictureAlignmentCenter
            .PictureSizeMode = fmPictureSizeModeClip
            .PictureTiling = False
        End With
        With Label1
            .Left = 36
            .Top = 6
            .Height = 12
            .Width = Me.Width
            .Caption = " Mustafa ULUSARAÇ"
            .ForeColor = vbBlue
            .Font.Bold = True
            .SpecialEffect = fmSpecialEffectFlat
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignLeft
        End With
        With Label2
            .Left = 36
            .Top = 18
            .Height = 12
            .Width = Me.Width
            .Caption = "
01ulusarac@superonline.com"
            .ForeColor = vbBlue
            .Font.Bold = True
            .SpecialEffect = fmSpecialEffectFlat
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignLeft
        End With
        With Label3
            .Left = 6
            .Top = 36
            .Height = 30
            .Width = 192
            .Caption = "Bilgi Ağacı [TreeView]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignCenter
        End With
        With TreeView1
            .Left = 6
            .Top = 72
            .Height = 168
            .Width = 192
            .BorderStyle = ccFixedSingle
            .Appearance = ccFlat
            Set .ImageList = ImageList1
            .Indentation = 14
            .LabelEdit = tvwManual
            .HideSelection = False
            .FullRowSelect = False
            .LineStyle = tvwRootLines
        End With
        With Label4
            .Left = 204
            .Top = 36
            .Height = 30
            .Width = 180
            .Caption = "Düğüm İlişkisi ve Bilgiler [Relationship Between The Node & Information]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = fmTextAlignCenter
        End With
        With Label5
            .Left = 204
            .Top = 72
            .Height = 18
            .Width = 96
            .Caption = " Dal [Node]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox1
            .Left = 306
            .Top = 72
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
        With Label6
            .Left = 204
            .Top = 96
            .Height = 18
            .Width = 96
            .Caption = " Kök Dal [Parent]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With ComboBox1
            .Left = 306
            .Top = 96
            .Height = 18
            .Width = 42
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
            .ListWidth = 42
            .ColumnWidths = 30
        End With
        With CommandButton1
            .Left = 348
            .Top = 96
            .Height = 18
            .Width = 36
            .ForeColor = vbRed
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .Caption = "Move"
        End With
        With Label7
            .Left = 204
            .Top = 120
            .Height = 18
            .Width = 96
            .Caption = " Veri1 [Data1]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox2
            .Left = 306
            .Top = 120
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
        With Label8
            .Left = 204
            .Top = 144
            .Height = 18
            .Width = 96
            .Caption = " Veri2 [Data2]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox3
            .Left = 306
            .Top = 144
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
        With Label9
            .Left = 204
            .Top = 168
            .Height = 18
            .Width = 96
            .Caption = " Veri3 [Data3]"
            .ForeColor = VBA.RGB(120, 120, 120)
            .Font = "Arial Narrow"
            .Font.Bold = True
            .Font.Size = 10
            .SpecialEffect = fmSpecialEffectEtched
            .BorderStyle = fmBorderStyleNone
            .TextAlign = Left
        End With
        With TextBox4
            .Left = 306
            .Top = 168
            .Height = 18
            .Width = 78
            .SpecialEffect = fmSpecialEffectEtched
            .ForeColor = vbBlue
            .Font = "Arial Narrow"
            .Font.Bold = False
            .Font.Size = 10
        End With
    End With
End Sub
Sub Sayfa_Kur()

    On Error Resume Next
    Dim Eleman As Worksheet
    For Each Eleman In ThisWorkbook.Worksheets
        If Eleman.Name = "Veriler" Then
            Sheets("Veriler").Select
            GoTo Devam
        End If
    Next Eleman
    ThisWorkbook.Worksheets.Add Sheets(1)
    ActiveSheet.Name = "Veriler"
Devam:
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").FormulaR1C1 = "Node"
    Range("A2").FormulaR1C1 = "C"
    Range("A3").FormulaR1C1 = "B"
    Range("A4").FormulaR1C1 = "A"
    Range("A5").FormulaR1C1 = "D"
    Range("A6").FormulaR1C1 = "F"
    Range("A7").FormulaR1C1 = "G"
    Range("A8").FormulaR1C1 = "E"
    Range("A9").FormulaR1C1 = "H"
    Range("A10").FormulaR1C1 = "I"
    Range("A11").FormulaR1C1 = "J"
    Range("B1").FormulaR1C1 = "Parent"
    Range("B2").FormulaR1C1 = "J"
    Range("B3").FormulaR1C1 = ""
    Range("B4").FormulaR1C1 = "B"
    Range("B5").FormulaR1C1 = ""
    Range("B6").FormulaR1C1 = "D"
    Range("B7").FormulaR1C1 = "D"
    Range("B8").FormulaR1C1 = "A"
    Range("B9").FormulaR1C1 = "I"
    Range("B10").FormulaR1C1 = "F"
    Range("B11").FormulaR1C1 = ""
    Range("C1").FormulaR1C1 = "Data1"
    Range("C2").FormulaR1C1 = "C En"
    Range("C3").FormulaR1C1 = "B En"
    Range("C4").FormulaR1C1 = "A En"
    Range("C5").FormulaR1C1 = "D En"
    Range("C6").FormulaR1C1 = "F En"
    Range("C7").FormulaR1C1 = "G En"
    Range("C8").FormulaR1C1 = "E En"
    Range("C9").FormulaR1C1 = "H En"
    Range("C10").FormulaR1C1 = "I En"
    Range("C11").FormulaR1C1 = "J En"
    Range("D1").FormulaR1C1 = "Data2"
    Range("D2").FormulaR1C1 = "C Boy"
    Range("D3").FormulaR1C1 = "B Boy"
    Range("D4").FormulaR1C1 = "A Boy"
    Range("D5").FormulaR1C1 = "D Boy"
    Range("D6").FormulaR1C1 = "F Boy"
    Range("D7").FormulaR1C1 = "G Boy"
    Range("D8").FormulaR1C1 = "E Boy"
    Range("D9").FormulaR1C1 = "H Boy"
    Range("D10").FormulaR1C1 = "I Boy"
    Range("D11").FormulaR1C1 = "J Boy"
    Range("E1").FormulaR1C1 = "Data3"
    Range("E2").FormulaR1C1 = "C Yükseklik"
    Range("E3").FormulaR1C1 = "B Yükseklik"
    Range("E4").FormulaR1C1 = "A Yükseklik"
    Range("E5").FormulaR1C1 = "D Yükseklik"
    Range("E6").FormulaR1C1 = "F Yükseklik"
    Range("E7").FormulaR1C1 = "G Yükseklik"
    Range("E8").FormulaR1C1 = "E Yükseklik"
    Range("E9").FormulaR1C1 = "H Yükseklik"
    Range("E10").FormulaR1C1 = "I Yükseklik"
    Range("E11").FormulaR1C1 = "J Yükseklik"
    With Range("A1:E1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ShrinkToFit = True
        With .Font
            .Name = "Arial Narrow"
            .FontStyle = "Normal"
            .Size = 12
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0.4
            .ThemeFont = xlThemeFontNone
        End With
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 16711680
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
    With Range("A2:B11")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ShrinkToFit = True
    End With
    Columns("A:E").ColumnWidth = 12
    Range("A1").Select
End Sub


'Module1

Sub Form_Open()

    On Error Resume Next
    UserForm1.Show 0
End Sub
'Sub ReferenceList()

'    On Error Resume Next
'    Dim Eleman, No
'    No = 1
'    For Each Eleman In ThisWorkbook.VBProject.References
'        Cells(No, 1) = "Name: "
'        Cells(No, 2) = Eleman.Name
'        Cells(No, 3) = ", Description: "
'        Cells(No, 4) = Eleman.Description
'        Cells(No, 5) = ", Full Path: "
'        Cells(No, 6) = Eleman.FullPath
'        No = No + 1
'    Next Eleman
'End Sub

1 Haziran 2006 Perşembe

Microsoft.Jet.OLEDB.4.0 Connection



'UserForm1


'Eklenecek referans: ActiveX Data Objects 2.8 Library
'Path: c:\Program Files\Common Files\System\ado\msado15.dll


Option Explicit
Private t As Integer, c As Integer, f As Integer, r As Integer
Private Bağlantı As ADODB.Connection
Private KayıtDüzeni As ADODB.Recordset
Private TabloSayısı As Integer, TabloÖzellikleriSayısı As Integer
Private TabloAdı As String
Private TabloDüzeni As ADODB.Recordset
Private KolonSayısı As Integer, KolonÖzellikleriSayısı As Integer
Private KolonBaşlığı As String
Private Liste As MSForms.ListBox

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD ®] Microsoft.Jet.OLEDB.4.0 Connection"
.Width = 360
.Height = 240
Set Liste = .Controls.Add("Forms.ListBox.1")
With Liste
.BackColor = &H80000018
.Top = 6
.Left = 6
.Width = 360 - 18
.Height = 240 - 36
End With
DoEvents
End With
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Set Bağlantı = New ADODB.Connection
With Bağlantı
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=C:\SLVT.xls;Extended Properties=Excel 8.0;"
.CursorLocation = adUseClient
.Open
End With
Set KayıtDüzeni = Bağlantı.OpenSchema(adSchemaTables)
TabloSayısı = KayıtDüzeni.RecordCount
TabloÖzellikleriSayısı = KayıtDüzeni.Fields.Count
For t = 1 To TabloSayısı
TabloAdı = KayıtDüzeni.Fields("TABLE_NAME").Value
Liste.AddItem "Table #" & t & ": " & TabloAdı
For f = 0 To TabloÖzellikleriSayısı - 1
Liste.AddItem vbTab & vbTab & KayıtDüzeni.Fields(f).Name & vbTab & KayıtDüzeni.Fields(f).Value
Next f
Set TabloDüzeni = Bağlantı.OpenSchema(adSchemaColumns, Array(Empty, Empty, TabloAdı, Empty))
KolonSayısı = TabloDüzeni.RecordCount
KolonÖzellikleriSayısı = TabloDüzeni.Fields.Count
For c = 1 To KolonSayısı
KolonBaşlığı = TabloDüzeni.Fields("COLUMN_NAME").Value
Liste.AddItem vbTab & vbTab & "Column #" & c & ": " & KolonBaşlığı
For f = 0 To KolonÖzellikleriSayısı - 1
Liste.AddItem vbTab & vbTab & vbTab & TabloDüzeni.Fields(f).Name & vbTab & TabloDüzeni.Fields(f).Value
Next f
TabloDüzeni.MoveNext
Next c
TabloDüzeni.Close
KayıtDüzeni.MoveNext
Next t
KayıtDüzeni.Close
Bağlantı.Close
End Sub

Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul
Anadolu Üniversitesi Açık Öğretim Fakültesi