Satırlarda toplu düzenleme ve sıralama

[Serdarrk]

Merhaba,

Aşağıdaki ekteki sayfalarda birinci satırda tarihler ve bu tarihlerin sonunda -1 ibaresi bulunmakta. Amacım bu ibareyi toplu olarak her sütundan silmek ve tarihleri(sütunları) 02 Ocak'tan 31 Aralık'a şeklinde sıralamak.

http://s3.dosya.tc/server14/6h9ci9/01.02.1999-1.xls.html

 

[Ömer BARAN]

Merhaba.

-- Belgeniz açıkken ALT+F11 tuşlarına basarak VBA ekranının görünmesini sağlayın,
-- Açılan VBA ekranında üstteki MENÜ kısmından INSERT=>MODULEyi seçin.
-- Sağdaki boş alana aşağıdaki kod blokunu yapıştırın,
-- Fareyi kullanarak imlecin kod'un ilk satırına gelmesini sağlayın,
-- F5 tuşuna basarak birkaç saniye bekleyin.
.

Sub TARIH_SUTUNLARINI_SIRALA()
Application.ScreenUpdating = False
zaman = Timer
For Each shf In ThisWorkbook.Sheets
    sonsut = shf.[B1].End(xlToRight).Column
    If shf.Name = "Sayfa1" Then sonsut = sonsut - 1
    On Error Resume Next
    For sutt = 2 To sonsut
        shf.Cells(1, sutt).Value = CDate(Replace(shf.Cells(1, sutt).Text, "-1", ""))
    Next
    For sut = 2 To shf.Cells(1, Columns.Count).End(xlToLeft).Column
        say = say + 1
        a = WorksheetFunction.Match(WorksheetFunction.Small(shf.Range("1:1"), say), shf.Range("1:1"), 0)
        shf.Columns(a).Cut: shf.Cells(1, sut).Insert Shift:=xlToRight
    Next
Next
Application.ScreenUpdating = True
MsgBox "BİTTİ" & vbLf & "İşlem süresi: " & Format(Timer - zaman, "0.0") & " saniye."
End Sub

 

[Serdarrk]

İlginiz ve emeğiniz için çok teşekkür ederim. Hocam bir sorum daha olacak size. Sayfa2ler için uygulamayı beceremedim. If shf.Name = "Sayfa2" yapmam yeterli değil midir?

 

[Ömer BARAN]

Merhaba.

-- Verdiğim kod tüm sayfalarda işlem yapıyor zaten.
For Each shf In ThisWorkbook.Sheets

-- Kod'daki If shf.Name = "Sayfa1" Then sonsut = sonsut - 1 satırının nedeni,
Sayfa 1'de işlem yapıldığı için değil, Sayfa1'in en son sütununda TARİH OLMAYAN,
sanırım diğer sayfada tablonun devamının olduğunu belirtmek için yazılmış sayfa adının yer alması
ve makronun o sütunda işlem yapmaması için.
.

 

[Serdarrk]

Çok sağolun Ömer Bey, işime yaradı teşekkür ederim

 

[Serdarrk]

Sub nicework2()

Dim wbOpen As Workbook
Dim MyDir As String
MyDir = "C:\Users\serdar\Desktop\RENAMER\2001\1"

'Comment out the 3 lines below to debug'Application.ScreenUpdating = False'Application.Calculation = xlCalculationManual'On Error Resume Next
strExtension = Dir(MyDir & "\*.xls")


While strExtension <> vbNullString
Set wbOpen = Workbooks.Open(MyDir & "\" & strExtension)

With wbOpen
Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("N1- 1").Select
    Rows("12:123").Select
    Selection.Copy
    Sheets("Sayfa1").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=105
    Sheets("N1- 2").Select
    Rows("14:123").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sayfa1").Select
    Range("A113").Select
    ActiveSheet.Paste
    Sheets("N1- 3").Select
    Rows("14:200").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sayfa1").Select
    ActiveWindow.SmallScroll Down:=90
    Range("A223").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=15
End With

strExtension = Dir
Wend

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[ylmzbysl]

teşekkürler

 

[Serdarrk]

Merhaba.

-- Belgeniz açıkken ALT+F11 tuşlarına basarak VBA ekranının görünmesini sağlayın,
-- Açılan VBA ekranında üstteki MENÜ kısmından INSERT=>MODULEyi seçin.
-- Sağdaki boş alana aşağıdaki kod blokunu yapıştırın,
-- Fareyi kullanarak imlecin kod'un ilk satırına gelmesini sağlayın,
-- F5 tuşuna basarak birkaç saniye bekleyin.
.

Sub TARIH_SUTUNLARINI_SIRALA()
Application.ScreenUpdating = False
zaman = Timer
For Each shf In ThisWorkbook.Sheets
    sonsut = shf.[B1].End(xlToRight).Column
    If shf.Name = "Sayfa1" Then sonsut = sonsut - 1
    On Error Resume Next
    For sutt = 2 To sonsut
        shf.Cells(1, sutt).Value = CDate(Replace(shf.Cells(1, sutt).Text, "-1", ""))
    Next
    For sut = 2 To shf.Cells(1, Columns.Count).End(xlToLeft).Column
        say = say + 1
        a = WorksheetFunction.Match(WorksheetFunction.Small(shf.Range("1:1"), say), shf.Range("1:1"), 0)
        shf.Columns(a).Cut: shf.Cells(1, sut).Insert Shift:=xlToRight
    Next
Next
Application.ScreenUpdating = True
MsgBox "BİTTİ" & vbLf & "İşlem süresi: " & Format(Timer - zaman, "0.0") & " saniye."
End Sub

Ömer Bey, bunu satırlara uygulamak için nasıl değiştirmemiz gerekir? Örnek olarak aşağıdaki dosyada B sütununda bulunan tarihlere göre A,B ve C sütununu sıralamak için.

http://www.dosya.tc/server12/dg6bdx/orneki.xls.html