Sıralı olarak sayfa isimlendirme

H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Aşağıdaki dosyayı deneyiniz.

Kod: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
  
  Dim wkbYKTP     As Excel.Workbook
  Dim wkbBKTP     As Excel.Workbook
  Dim wksSSYF     As Excel.Worksheet
  Dim wksYSYF     As Excel.Worksheet
  Dim xvbPROJ     As Object 'Excel.Workbook
  
  Dim dTARIH      As Variant
  Dim intYKCS     As Integer
  Dim intSNGN     As Integer
  Dim strYADI     As String
  Dim lngLINE     As Long
  
    dTARIH = InputBox("İşlem Yapacağınız Ayın ilkgününü aa/gg/yyyy şeklinde giriniz!")
    If IsDate(dTARIH) = False Then
      MsgBox "girilen değer tarih değil" 'denetim ekle
      GoTo endProc
    End If
  
  Set wkbYKTP = Workbooks.Add
  Set wkbBKTP = ThisWorkbook
  Set wksSSYF = wkbBKTP.Worksheets("SABLON")
 
    intSNGN = Day(Format((DateSerial(Year(dTARIH), Month(dTARIH) + 1, 1)) - 1, "dd/mm/yyyy"))
    intYKCS = wkbYKTP.Sheets.Count
    strYADI = FncHsr_YazAy((Month(dTARIH))) & " " & Year(dTARIH) & ".xls"
    
    If Fnc_DsyaVarMi("c:\Deneme\" & strYADI) = True Then
      MsgBox "BU İSİMDE DOSYA DAHA ÖNCE OLUŞTURULMUŞ"
      GoTo endProc
    Else
      wkbYKTP.SaveAs Filename:="c:\Deneme\" & strYADI, _
          FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
          ReadOnlyRecommended:=False, CreateBackup:=False
    End If

    For i = 1 To intSNGN
      wksSSYF.Copy After:=wkbYKTP.Sheets(wkbYKTP.Sheets.Count)
      Set wksYSYF = ActiveSheet
      wksYSYF.Name = Format(i & "." & Month(dTARIH) & "." & Year(dTARIH), "dd.mm.yyyy")
    Next
  
    With wkbYKTP
     For i = intYKCS To 1 Step -1
       Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
       .Sheets(i).Delete
       Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
     Next i
    End With
  
      wksSSYF.Copy After:=wkbYKTP.Sheets(wkbYKTP.Sheets.Count)
      Set wksYSYF = ActiveSheet
      wksYSYF.Name = "TOPLAM"
      
      
Rem Yeni Çalışma Kitabının ThisWorkbook Modülüne kod yaz...
    wkbYKTP.Activate
    
'    Set xvbPROJ = wkbYKTP.VBProject.VBComponents("BuÇalışmaKitabı")
    Set xvbPROJ = wkbYKTP.VBProject.VBComponents(1)
    lngLINE = 0
      With xvbPROJ.CodeModule
         'Sorun2: Daha evvel projede hiç satır yoksa lngLINE değeri 0 olsun
  '      lngLINE = .CountOfLınes
        .InsertLines lngLINE + 1, "Private Sub Workbook_SheetActivate(ByVal Sh As Object)"
        .InsertLines lngLINE + 2, "Rem Excel.web.tr/hsayar tarafından hazırlanan makro ile ACİL MÜDAHALE PROGRAMI ŞABLON dosyasından oluşturulmuştur."
        .InsertLines lngLINE + 4, "Dim wksACT    As Excel.Worksheet"
        .InsertLines lngLINE + 5, "Dim wksONC    As Excel.Worksheet"
        .InsertLines lngLINE + 6, "Dim rngRPR    As Excel.Range"
        .InsertLines lngLINE + 7, ""
        .InsertLines lngLINE + 8, "Set wksACT = ThisWorkbook.ActiveSheet"
        .InsertLines lngLINE + 9, ""
        .InsertLines lngLINE + 11, "with wksACT"
        .InsertLines lngLINE + 12, "  If .Index = 1 Then GoTo isleyissonu"
        .InsertLines lngLINE + 13, "  If Left(.Name, 2) = " & Chr(34) & "01" & Chr(34) & " Then GoTo isleyissonu"
        .InsertLines lngLINE + 14, "  If .Name = " & Chr(34) & "SABLON" & Chr(34) & " Then GoTo isleyissonu"
        .InsertLines lngLINE + 15, "end with"
        .InsertLines lngLINE + 16, ""
        .InsertLines lngLINE + 17, "Set wksONC = ThisWorkbook.Worksheets(wksACT.Index - 1)"
        .InsertLines lngLINE + 18, ""
        .InsertLines lngLINE + 19, "  with wksONC"
        .InsertLines lngLINE + 20, "    If .Range(" & Chr(34) & "L5" & Chr(34) & ").Text =" & Chr(34) & Chr(34) & " Then"
        .InsertLines lngLINE + 21, "      MsgBox " & Chr(34) & "Lütfen " & Chr(34) & Chr(38) & Space(1) & ".Name" & Space(1) & Chr(38) & Chr(34) & " adlı sayfada Rapor numarasını giriniz." & Chr(34)
        .InsertLines lngLINE + 22, "      .Select"
        .InsertLines lngLINE + 23, "      Range(" & Chr(34) & "L5" & Chr(34) & ").Select"
        .InsertLines lngLINE + 24, "    End If"
        .InsertLines lngLINE + 25, "  end with"
        .InsertLines lngLINE + 26, ""
        .InsertLines lngLINE + 28, "isleyissonu:"
        .InsertLines lngLINE + 29, ""
        .InsertLines lngLINE + 30, "Set wksACT = Nothing"
        .InsertLines lngLINE + 31, "Set wksONC = Nothing"
        .InsertLines lngLINE + 33, ""
        .InsertLines lngLINE + 34, ""
        .InsertLines lngLINE + 35, "End Sub"
      End With
    Set xvbPROJ = Nothing
    

Rem Yeni Çalışma Kitabında standartmodül oluştur ve adını modTOPLAM yap
    Set xvbPROJ = wkbYKTP.VBProject.VBComponents.Add(vbext_ct_StdModule)
    xvbPROJ.Name = "modTOPLAM"
    lngLINE = 0
      With xvbPROJ.CodeModule
        .InsertLines lngLINE + 1, "Sub AY_TOPLAMI_AL()"
        .InsertLines lngLINE + 2, "Rem Excel.web.tr/hsayar tarafından hazırlanan makro ile ACİL MÜDAHALE PROGRAMI ŞABLON dosyasından oluşturulmuştur."
        .InsertLines lngLINE + 3, "REM Bu Çalışma Kitabındaki Günlük sayfalarının toplamını alır."
        .InsertLines lngLINE + 5, "Dim intSYF As Integer"
        .InsertLines lngLINE + 6, "Dim intSAT As Integer"
        .InsertLines lngLINE + 7, "Dim intSUT As Integer"
        .InsertLines lngLINE + 8, ""
        .InsertLines lngLINE + 10, "  Range(Cells(13, 9), Cells(28, 13)).ClearContents"
        .InsertLines lngLINE + 11, "  Range(Cells(33, 3), Cells(37, 5)).ClearContents"
        .InsertLines lngLINE + 12, ""
        .InsertLines lngLINE + 13, "  For intSYF = 1 To Sheets.Count - 1"
        .InsertLines lngLINE + 14, "    For intSUT = 9 To 13"
        .InsertLines lngLINE + 15, "      For intSAT = 13 To 28"
        .InsertLines lngLINE + 16, "        Cells(intSAT, intSUT) = Cells(intSAT, intSUT) + Sheets(intSYF).Cells(intSAT, intSUT)"
        .InsertLines lngLINE + 17, "      Next intSAT"
        .InsertLines lngLINE + 18, "    Next intSUT"
        .InsertLines lngLINE + 19, ""
        .InsertLines lngLINE + 20, "    For intSUT = 3 To 5"
        .InsertLines lngLINE + 21, "      For intSAT = 33 To 37"
        .InsertLines lngLINE + 22, "        Cells(intSAT, intSUT) = Cells(intSAT, intSUT) + Sheets(intSYF).Cells(intSAT, intSUT)"
        .InsertLines lngLINE + 23, "      Next intSAT"
        .InsertLines lngLINE + 24, "    Next intSUT"
        .InsertLines lngLINE + 25, "  Next intSYF "
        .InsertLines lngLINE + 26, "End Sub"
      End With
    Set xvbPROJ = Nothing
    wkbYKTP.Save
    
endProc:
  Set wkbYKTP = Nothing
  Set wkbBKTP = Nothing
  Set wksSSYF = Nothing
  Set wksYSYF = Nothing

Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
sn tekeli; command1 e bağlı kodaları aşağıdakilerle değiştirip denermisiniz birde?

ben ofis2010 ve ofis 2007 ile çalışıyorum ortaya çıkan ("thisworkbook","BuÇlaışmakitabı") karmaşasını engellemesi için farklı bir kod denedim. siz de çalıştığını versiyonu yazınız.


Kod: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
  
  Dim wkbYKTP     As Excel.Workbook
  Dim wkbBKTP     As Excel.Workbook
  Dim wksSSYF     As Excel.Worksheet
  Dim wksYSYF     As Excel.Worksheet
'  Dim wksTSYF     As Excel.Worksheet
  Dim xvbPROJ     As Object 'Excel.Workbook
  Dim myVBComp    As Object
  
  Dim dTARIH      As Variant
  Dim intYKCS     As Integer
  Dim intSNGN     As Integer
  Dim strYADI     As String
  Dim lngLINE     As Long
  Dim strPROJ     As String
    
    dTARIH = InputBox("İşlem Yapacağınız Ayın ilkgününü aa/gg/yyyy şeklinde giriniz!")
    If IsDate(dTARIH) = False Then
      MsgBox "girilen değer tarih değil" 'denetim ekle
      GoTo endProc
    End If
  
  Set wkbYKTP = Workbooks.Add
  Set wkbBKTP = ThisWorkbook
  Set wksSSYF = wkbBKTP.Worksheets("SABLON")
 
    intSNGN = Day(Format((DateSerial(Year(dTARIH), Month(dTARIH) + 1, 1)) - 1, "dd/mm/yyyy"))
    intYKCS = wkbYKTP.Sheets.Count
    strYADI = FncHsr_YazAy((Month(dTARIH))) & "" & Year(dTARIH) & ".xls"
    
    If Fnc_DsyaVarMi("c:\Deneme\" & strYADI) = True Then
      MsgBox "BU İSİMDE DOSYA DAHA ÖNCE OLUŞTURULMUŞ"
      GoTo endProc
    Else
      wkbYKTP.SaveAs Filename:="c:\Deneme\" & strYADI, _
          FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
          ReadOnlyRecommended:=False, CreateBackup:=False
    End If

    For i = 1 To intSNGN
      wksSSYF.Copy After:=wkbYKTP.Sheets(wkbYKTP.Sheets.Count)
      Set wksYSYF = ActiveSheet
      wksYSYF.Name = Format(i & "." & Month(dTARIH) & "." & Year(dTARIH), "dd.mm.yyyy")
    Next
  
    With wkbYKTP
     For i = intYKCS To 1 Step -1
       Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
       .Sheets(i).Delete
       Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
     Next i
    End With
  
      wksSSYF.Copy After:=wkbYKTP.Sheets(wkbYKTP.Sheets.Count)
      Set wksYSYF = ActiveSheet
      wksYSYF.Name = "TOPLAM"
      
      
Rem Yeni Çalışma Kitabının ThisWorkbook Modülüne kod yaz...
    wkbYKTP.Activate
    
    'Oluşan Yeni Çalışma Kitabında ThisWorkbok kod modulünün adını bul...
      For Each myVBComp In wkbYKTP.VBProject.VBComponents
        With myVBComp
          If .Type = 100 And .Properties.Count = 127 Then
            'workbook           .Properties.Count = 127
            'workSheet          .Properties.Count = 66
            'Graphic            .Properties.Count = 76
            With .CodeModule
              strPROJ = .Name '"BuÇalışmaKitabı","ThisWorkbook", İndex X vs..
            End With
          Else
            ''MsgBox "bulamadım"
          End If
        End With
      Next myVBComp

    Set xvbPROJ = wkbYKTP.VBProject.VBComponents(strPROJ)
    lngLINE = 0
      With xvbPROJ.CodeModule
         'Sorun2: Daha evvel projede hiç satır yoksa lngLINE değeri 0 olsun
  '      lngLINE = .CountOfLınes
        .InsertLines lngLINE + 1, "Private Sub Workbook_SheetActivate(ByVal Sh As Object)"
        .InsertLines lngLINE + 2, "Rem Excel.web.tr/hsayar tarafından hazırlanan makro ile ACİL MÜDAHALE PROGRAMI ŞABLON dosyasından oluşturulmuştur."
        .InsertLines lngLINE + 4, "Dim wksACT    As Excel.Worksheet"
        .InsertLines lngLINE + 5, "Dim wksONC    As Excel.Worksheet"
        .InsertLines lngLINE + 6, "Dim rngRPR    As Excel.Range"
        .InsertLines lngLINE + 7, ""
        .InsertLines lngLINE + 8, "Set wksACT = ThisWorkbook.ActiveSheet"
        .InsertLines lngLINE + 9, ""
        .InsertLines lngLINE + 11, "with wksACT"
        .InsertLines lngLINE + 12, "  If .Index = 1 Then GoTo isleyissonu"
        .InsertLines lngLINE + 13, "  If Left(.Name, 2) = " & Chr(34) & "01" & Chr(34) & " Then GoTo isleyissonu"
        .InsertLines lngLINE + 14, "  If .Name = " & Chr(34) & "TOPLAM" & Chr(34) & " Then GoTo isleyissonu"
        .InsertLines lngLINE + 15, "end with"
        .InsertLines lngLINE + 16, ""
        .InsertLines lngLINE + 17, "Set wksONC = ThisWorkbook.Worksheets(wksACT.Index - 1)"
        .InsertLines lngLINE + 18, ""
        .InsertLines lngLINE + 19, "  with wksONC"
        .InsertLines lngLINE + 20, "    If .Range(" & Chr(34) & "L5" & Chr(34) & ").Text =" & Chr(34) & Chr(34) & " Then"
        .InsertLines lngLINE + 21, "      MsgBox " & Chr(34) & "Lütfen " & Chr(34) & Chr(38) & Space(1) & ".Name" & Space(1) & Chr(38) & Chr(34) & " adlı sayfada Rapor numarasını giriniz." & Chr(34)
        .InsertLines lngLINE + 22, "      .Select"
        .InsertLines lngLINE + 23, "      Range(" & Chr(34) & "L5" & Chr(34) & ").Select"
        .InsertLines lngLINE + 24, "    End If"
        .InsertLines lngLINE + 25, "  end with"
        .InsertLines lngLINE + 26, ""
        .InsertLines lngLINE + 28, "isleyissonu:"
        .InsertLines lngLINE + 29, ""
        .InsertLines lngLINE + 30, "Set wksACT = Nothing"
        .InsertLines lngLINE + 31, "Set wksONC = Nothing"
        .InsertLines lngLINE + 33, ""
        .InsertLines lngLINE + 34, ""
        .InsertLines lngLINE + 35, "End Sub"
      End With
    Set xvbPROJ = Nothing
    

Rem Yeni Çalışma Kitabında standartmodül oluştur ve adını modTOPLAM yap
'    Set xvbPROJ = wkbYKTP.VBProject.VBComponents.Add(vbext_ct_StdModule)
'    xvbPROJ.Name = "modTOPLAM"

Rem Yeni Çalışma Kitabında oluşan TOPLAM isimli çalışma sayfasına kod yaz.
     strPROJ = wkbYKTP.Worksheets("TOPLAM").CodeName
     Set xvbPROJ = wkbYKTP.VBProject.VBComponents(strPROJ)
     lngLINE = 0
      With xvbPROJ.CodeModule
        .InsertLines lngLINE + 1, "Sub AY_TOPLAMI_AL()"
        .InsertLines lngLINE + 2, "Rem Excel.web.tr/hsayar tarafından hazırlanan makro ile ACİL MÜDAHALE PROGRAMI ŞABLON dosyasından oluşturulmuştur."
        .InsertLines lngLINE + 3, "REM Bu Çalışma Kitabındaki Günlük sayfalarının toplamını alır."
        .InsertLines lngLINE + 5, "Dim intSYF As Integer"
        .InsertLines lngLINE + 6, "Dim intSAT As Integer"
        .InsertLines lngLINE + 7, "Dim intSUT As Integer"
        .InsertLines lngLINE + 8, "  Application.ScreenUpdating = False"
        .InsertLines lngLINE + 10, "  Range(Cells(13, 9), Cells(28, 13)).ClearContents"
        .InsertLines lngLINE + 11, "  Range(Cells(33, 3), Cells(37, 5)).ClearContents"
        .InsertLines lngLINE + 12, ""
        .InsertLines lngLINE + 13, "  For intSYF = 1 To Sheets.Count - 1"
        .InsertLines lngLINE + 14, "    For intSUT = 9 To 13"
        .InsertLines lngLINE + 15, "      For intSAT = 13 To 28"
        .InsertLines lngLINE + 16, "        Cells(intSAT, intSUT) = Cells(intSAT, intSUT) + Sheets(intSYF).Cells(intSAT, intSUT)"
        .InsertLines lngLINE + 17, "      Next intSAT"
        .InsertLines lngLINE + 18, "    Next intSUT"
        .InsertLines lngLINE + 19, ""
        .InsertLines lngLINE + 20, "    For intSUT = 3 To 5"
        .InsertLines lngLINE + 21, "      For intSAT = 33 To 37"
        .InsertLines lngLINE + 22, "        Cells(intSAT, intSUT) = Cells(intSAT, intSUT) + Sheets(intSYF).Cells(intSAT, intSUT)"
        .InsertLines lngLINE + 23, "      Next intSAT"
        .InsertLines lngLINE + 24, "    Next intSUT"
        .InsertLines lngLINE + 25, "  Next intSYF "
        .InsertLines lngLINE + 26, "  Application.ScreenUpdating = TRUE"
        .InsertLines lngLINE + 27, "End Sub"
      End With
    Set xvbPROJ = Nothing
    Application.DisplayAlerts = False
    wkbYKTP.Save
    Application.DisplayAlerts = True
endProc:
  Set wkbYKTP = Nothing
  Set wkbBKTP = Nothing
  Set wksSSYF = Nothing
  Set wksYSYF = Nothing

Application.ScreenUpdating = True
End Sub
 
Y

y_tekeli

Katılım
9 Aralık 2006
Mesajlar
134
Excel Vers. ve Dili
microsoft office professional plus 2010 TR
Işte budur

Emeği geçen herkese teşşekür ediyorum
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Rica ederim.
 
K

Knuckless

Banned
Katılım
27 Ocak 2014
Mesajlar
2
Excel Vers. ve Dili
Excel 2010-Tr
ellerine sağlık usta
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst