Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Nisan 2011 Çarşamba

More Than Three Columns Array in Excel to Sort Data.







'Module1


'A) Windows XP® Office 2003® Normal Referance List
'Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'Description: OLE Automation, FullPath: C:\WINDOWS\system32\stdole2.tlb
'Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL

Option Explicit
Private Const Kayıt As Double = 600 'For Worksheet; Max 65536 rows
Private Const Kolon As Double = 6 'For Worksheet; Max 256 columns
Dim Elde As Variant, Sorgu As Variant, EldeS As Variant, SorguS As Variant, EldeÖ(1 To Kolon) As Variant, SorguÖ(1 To Kolon) As Variant, Rastgele As Variant
Dim i As Single, ii As Single, iii As Single, iv As Single, v As Single
Dim En As Integer, Boy As Integer
Dim Sayfa As Worksheet
Dim Ton As Double
Dim Bellek(1 To Kayıt, 1 To Kolon)
Dim Sorgulama As Double
Dim Adres As String
Sub Süz() 'to filter
            On Error Resume Next
            Call Temizle
            For i = 1 To Kayıt
                        For ii = 1 To Kolon
                                   If ii = 1 Then
                                               Bellek(i, ii) = i
                                   ElseIf ii = 2 Then
                                               Rastgele = VBA.Round(VBA.Rnd * 10, 0)
                                               Bellek(i, ii) = VBA.Switch(Rastgele = 0, "A", Rastgele = 1, "B", Rastgele = 2, "C", Rastgele = 3, "D", Rastgele = 4, "E", Rastgele = 5, "F", Rastgele = 6, "G", Rastgele = 7, "H", Rastgele = 8, "I", Rastgele = 9, "J", Rastgele > 9, "K")
                                   Else
                                               Rastgele = VBA.Round(VBA.Rnd * 10, 0)
                                               Bellek(i, ii) = Rastgele
                                   End If
                        Next ii
            Next i
            Sheets("Data").Select
            Range(Cells(2, 1), Cells(601, Kolon)).Select
            Adres = Application.Selection.Address
            Sheets("Data").Range(Adres) = Bellek
            Call Gruplama(Bellek, Kolon, Kayıt, Sheets("Data"))
            Call Süzgeç(Bellek, Kolon, Kayıt)
            Sheets("SortDataMax256Columns").Range(Adres) = Bellek
            Call Gruplama(Bellek, Kolon, Kayıt, Sheets("SortDataMax256Columns"))
            Call Kontrol
End Sub
Private Function Süzgeç(Bellek, En, Boy) 'Filter
            On Error Resume Next
            For i = 1 To Boy
                       For ii = 1 To En
                                   Sorgu = Bellek(i, ii)
                                   For v = (ii - 1) To 1 Step -1
                                              SorguÖ(v) = Bellek(i, (ii - v))
                                  Next v
                                  For iii = (i + 1) To Boy
                                               Elde = Bellek(iii, ii)
                                               For v = (ii - 1) To 1 Step -1
                                                           EldeÖ(v) = Bellek(iii, (ii - v))
                                               Next v
                                               Sorgulama = 1
                                              If ii > 2 Then
                                                           For v = 1 To (ii - 2)
                                                                       If SorguÖ(v) = EldeÖ(v) Then Sorgulama = Sorgulama * 1
                                                                       If SorguÖ(v) <> EldeÖ(v) Then Sorgulama = Sorgulama * 0
                                                           Next v
                                               End If
                                               If Sorgu > Elde And Sorgulama = 1 Then
                                                           Bellek(i, ii) = Elde
                                                           Bellek(iii, ii) = Sorgu
                                                           Sorgu = Elde
                                                           For iv = 1 To En
                                                                       If iv <> ii Then
                                                                                  SorguS = Bellek(i, iv)
                                                                                  EldeS = Bellek(iii, iv)
                                                                                  Bellek(i, iv) = EldeS
                                                                                  Bellek(iii, iv) = SorguS
                                                                       End If
                                                           Next iv
                                               End If
                                    Next iii
                                   Application.StatusBar = "Total Progress: [" & i & "/" & Boy & "] " & i & ". Item Progress: [" & ii & "/" & En & "]"
                                   DoEvents
                        Next ii
                        Application.StatusBar = "Total Progress: [" & i & "/" & Boy & "] " & i & ". Item Progress: [" & ii & "/" & En & "]"
                        DoEvents
            Next i
End Function
Private Function Gruplama(Bellek, En, Boy, Sayfa) 'to group
            On Error Resume Next
            For i = 1 To Boy
                       Select Case Bellek(i, 2)
                       Case "A": Ton = 35
                       Case "B": Ton = 36
                       Case "C": Ton = 37
                       Case "D": Ton = 38
                       Case "E": Ton = 39
                       Case "F": Ton = 40
                       Case "G": Ton = 41
                       Case "H": Ton = 42
                       Case "I": Ton = 43
                       Case "J": Ton = 44
                       Case "K": Ton = 45
                       End Select
                       For ii = 1 To En
                                   Sayfa.Cells((i + 1), ii).Interior.ColorIndex = Ton
                       Next ii
            Next i
End Function
Private Sub Kontrol() 'Control
            On Error Resume Next
            Sheets("Data").Select
            Range(Adres).Copy
            Sheets("ExcelSort3Columns").Select
            Range(Adres).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
           Range(Cells(1, 1), Cells(601, Kolon)).Select
           Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("D2"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
           Call Gruplama(Bellek, Kolon, Kayıt, Sheets("ExcelSort3Columns"))
           Range("A1").Select
End Sub
Private Sub Temizle() 'to clean
           On Error Resume Next
           Sheets("Data").Select
           If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "Data": VBA.Err.Number = 0
            Sheets("ExcelSort3Columns").Select
            If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "ExcelSort3Columns": VBA.Err.Number = 0
           Sheets("SortDataMax256Columns").Select
           If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "SortDataMax256Columns": VBA.Err.Number = 0
           Sheets("Control").Select
           If VBA.Err.Number > 0 Then ThisWorkbook.Worksheets.Add Sheets(1): ActiveSheet.Name = "Control": VBA.Err.Number = 0
            Sheets(Array("Data", "SortDataMax256Columns", "ExcelSort3Columns", "Control")).Select
            Cells.Select
            Selection.Delete Shift:=xlUp
           Sheets("Data").Activate
           Range("A1").Select
           With Selection
                        .FormulaR1C1 = "Caption1"
                        With .Characters(Start:=1, Length:=8).Font
                                   .Name = "Arial"
                                   .FontStyle = "Normal"
                                   .Size = 8
                                   .ColorIndex = 2
                        End With
                        .HorizontalAlignment = xlCenter
                       .VerticalAlignment = xlCenter
                       .WrapText = True
                       .Orientation = 90
                       .IndentLevel = 0
                       .ReadingOrder = xlContext
                       .Font.ColorIndex = 2
                       .Interior.ColorIndex = 5
                       .AutoFill Destination:=Rows("1:1"), Type:=xlFillDefault
            End With
            Range("A2").Select
            ActiveWindow.FreezePanes = False: ActiveWindow.FreezePanes = True
            For i = 1 To ThisWorkbook.Worksheets.Count
                        Sheets(i).Select
                       ActiveSheet.Rows("1:1").RowHeight = 45.75
                       Cells.Select
                       With Selection
                                   .Font.Name = "Arial"
                                   .Font.Size = 8
                                   .ColumnWidth = 3
                       End With
            Next i
            Sheets("Control").Select
            For i = 1 To Kayıt
                       For ii = 1 To Kolon
                                   If ii = 2 Then
                                               Cells(i + 1, ii).FormulaR1C1 = "=EXACT(SortDataMax256Columns!RC,ExcelSort3Columns!RC)"
                                               Cells(i + 1, ii).FormatConditions.Delete
                                               Cells(i + 1, ii).FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="TRUE"
                                               Cells(i + 1, ii).FormatConditions(1).Interior.ColorIndex = 3
                                   Else
                                               Cells(i + 1, ii).FormulaR1C1 = "=SortDataMax256Columns!RC-ExcelSort3Columns!RC"
                                               Cells(i + 1, ii).FormatConditions.Delete
                                               Cells(i + 1, ii).FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="0"
                                               Cells(i + 1, ii).FormatConditions(1).Interior.ColorIndex = 3
                                   End If
                       Next ii
            Next i
           Selection.Rows("1:1").RowHeight = 45.75: Sheets("Control").Columns("A:B").ColumnWidth = 4: Range("A1").Select
End Sub
Private Sub AlanTemizle() 'Area clean
            On Error Resume Next
            Sheets("Data").Range("A2:IV65536").ClearContents
            Sheets("Data").Range("A2:IV65536").Interior.ColorIndex = xlNone
            Sheets("ExcelSort3Columns").Range("A2:IV65536").ClearContents
            Sheets("ExcelSort3Columns").Range("A2:IV65536").Interior.ColorIndex = xlNone
            Sheets("SortDataMax256Columns").Range("A2:IV65536").ClearContents
            Sheets("SortDataMax256Columns").Range("A2:IV65536").Interior.ColorIndex = xlNone
            Sheets("Data").Select
            Range("A1").Select
End Sub

Blog Arşivi

Bu gadget'ta bir hata oluştu

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