• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Sütun ekleme

M

manisali50

Banned
Katılım
29 Ekim 2010
Mesajlar
471
Excel Vers. ve Dili
Excel2003
Arkadaşlar merhaba..
Elimdeki dosyaya sütun eklemek istiyorum..Bu eklediğim sütuna başka bir dosyadan veri aktarılacaktır..Ama sütun eklenmeden önceki halinde her sayfada formül ve makro olduğu için sütun eklendikten sonra tüm bu işlevler görevini yitirmektedir..Açıklama dosyalardadır..
Şimdiden teşekkürler
 

Ekli dosyalar

Arkadaşlar tekrar iyi geceler..Bugün 4. gün ve ben soruma hala yanıt alamadım..İlgilenirseniz sevinirim
 
Selamlar,

Gerekli TARİH sütununu ekledikten sonra aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit
 
Sub TEZGAH_ARIZALARINI_LİSTELE()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet, Sayfa As Worksheet
    Dim X As Integer, Y As Integer, VERİ1 As String, VERİ2 As String, SÜTUN As Byte
 
    Application.ScreenUpdating = False
 
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    Set K2 = Workbooks.Open(ThisWorkbook.Path & "\Tezgah sicil kartı ve Arıza bildirim formu.xls")
    SÜTUN = 4
    S1.Range("C2:I500").ClearContents
 
    K1.Activate
 
    For X = 2 To S1.Range("A500").End(3).Row
        VERİ1 = UCase(Replace(Replace(S1.Cells(X, 1), "i", "İ"), "ı", "I"))
        For Each Sayfa In K2.Worksheets
            For Y = 10 To Sayfa.Cells(500, 3).End(3).Row
                If Sayfa.Cells(Y, 3) <> "" Then
                    VERİ2 = UCase(Replace(Replace(Sayfa.Cells(Y, 7), "i", "İ"), "ı", "I"))
                    If InStr(1, VERİ2, VERİ1, vbTextCompare) > 0 Then
                        S1.Cells(X, 3) = Sayfa.Cells(Y, 3)
                        S1.Cells(X, 3).NumberFormat = "00""/""00""/""""2010"""
                        S1.Cells(X, SÜTUN) = Sayfa.Range("I5")
                        SÜTUN = SÜTUN + 1
                    End If
                End If
            Next
        Next
        SÜTUN = 4
    Next
   
    K2.Close False
 
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Selamlar,

Ayrıca TEZGAHLARI_SAYFALARA_AKTAR() kodunuda aşağıdaki şekilde değiştirmelisiniz.

Kod: 
Option Explicit
 
Sub TEZGAHLARI_SAYFALARA_AKTAR()
    Dim S1 As Worksheet, Sayfa As Worksheet
    Dim X As Integer, Satır As Integer
 
    Set S1 = Sheets("Sayfa1")
 
    For Each Sayfa In ThisWorkbook.Worksheets
    
    Next
 
    For X = 2 To S1.Range("A100").End(3).Row
        For Each Sayfa In ThisWorkbook.Worksheets
            If Left(Sayfa.Name, 2) = "CT TEZGAHLARI" Then
                If S1.Cells(X, "J") = "CT TEZGAHLARI" Then
                    Satır = Sayfa.Range("A44").End(3).Row + 1
                    If Satır = 43 Then
                        MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                        Set S1 = Nothing
                        Exit Sub
                    End If
                    Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
                End If
            End If
 
            If Left(Sayfa.Name, 2) = "CM TEZGAHLARI" Then
                If S1.Cells(X, "J") = "CM TEZGAHLARI" Then
                    Satır = Sayfa.Range("A44").End(3).Row + 1
                    If Satır = 43 Then
                        MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                        Set S1 = Nothing
                        Exit Sub
                    End If
                    Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
                End If
            End If
 
            If Left(Sayfa.Name, 2) = "KAYNAK" Then
                If S1.Cells(X, "J") = "KAYNAK" Then
                    Satır = Sayfa.Range("A44").End(3).Row + 1
                    If Satır = 43 Then
                        MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                        Set S1 = Nothing
                        Exit Sub
                    End If
                    Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
                End If
            End If
            If Left(Sayfa.Name, 2) = "ÜNİVERSAL" Then
                If S1.Cells(X, "J") = "ÜNİVERSAL" Then
                    Satır = Sayfa.Range("A44").End(3).Row + 1
                    If Satır = 43 Then
                        MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                        Set S1 = Nothing
                        Exit Sub
                    End If
                    Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
                End If
            End If
            If Left(Sayfa.Name, 2) = "TESTERE" Then
                If S1.Cells(X, "J") = "TESTERE" Then
                    Satır = Sayfa.Range("A44").End(3).Row + 1
                    If Satır = 43 Then
                        MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                        Set S1 = Nothing
                        Exit Sub
                    End If
                    Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
                End If
            End If
            If Left(Sayfa.Name, 2) = "BORU BÖLÜMÜ" Then
                If S1.Cells(X, "J") = "BORU BÖLÜMÜ" Then
                    Satır = Sayfa.Range("A44").End(3).Row + 1
                    If Satır = 43 Then
                        MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                        Set S1 = Nothing
                        Exit Sub
                    End If
                    Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
                End If
            End If
 
           If Left(Sayfa.Name, 2) = "KALIPHANE" Then
               If S1.Cells(X, "J") = "KALIPHANE" Then
                   Satır = Sayfa.Range("A44").End(3).Row + 1
                   If Satır = 43 Then
                       MsgBox "Satırlar doldu !" & Chr(10) & "İşleme devam etmek için lütfen satır ekleyiniz.", vbCritical
                       Set S1 = Nothing
                       Exit Sub
                   End If
                   Sayfa.Cells(Satır, "A") = S1.Cells(X, 1)
                    Sayfa.Range("C" & Satır & ":F" & Satır).Value = S1.Range("D" & X & ":I" & X).Value
               End If
           End If
        Next
    Next
 
    Set S1 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Hocam merhaba..
Size bahsettiğim gibi az önce internetimiz açıldı ve heyecanla açıp baktım..Tam da istediğim gibi olmuş..HARİKA..
Ama çok ufak bir sorun var..
"Satırları renklendir/Renkleri Sil" butonuna basınca satırı renklendirmiyor,başlık satırındaki dolgu rengi olan laciverti kaldırıyor..
Ama dediğim gibi harika olmuş..Bu ufak sorunu da hallederseniz sevinirim..
Allah sizlerden razı olsun..Elinize,emeğinize,ilginize,bilginize sağlık..
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Sub Renklendir()
    Dim i As Long
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        With Range("A" & i & ":J" & i)
            If Cells(i, "J") = "" Then
                .Interior.ColorIndex = 0
            ElseIf Cells(i, "J") = "BORU BÖLÜMÜ" Then
                .Interior.ColorIndex = 36
            ElseIf Cells(i, "J") = "CM TEZGAHLARI" Then
                .Interior.ColorIndex = 38
            ElseIf Cells(i, "J") = "CT TEZGAHLARI" Then
                .Interior.ColorIndex = 34
            ElseIf Cells(i, "J") = "KALIPHANE" Then
                .Interior.ColorIndex = 39
            ElseIf Cells(i, "J") = "KAYNAK" Then
                .Interior.ColorIndex = 35
            ElseIf Cells(i, "J") = "TESTERE" Then
                .Interior.ColorIndex = 33
            ElseIf Cells(i, "J") = "ÜNİVERSAL" Then
                .Interior.ColorIndex = 40
            End If
        End With
    Next i
End Sub
 
Hocam çok çok teşekkür ederim..
Hocam bu arada sevineceğiniz bir şey söyleyeyim size..Öğlen size yazdıktan sonra internetimiz kapandı..Ben sizlerden öğrendiklerimle sorunu çözdüm..Şimdi eve gelince size bunu yazmak için girdim,yanıtınızı gördüm..
Şu ufak ayrıntı dikkatimi çekti..
Bendeki ilk gönderdiğiniz örnekte;
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
satırındaki For i = 1 yazıyordu,ama işlevini görüyordu..Ben sizin gönderdiğinizle değiştirdim tabii ki,ama merak ettim sadece..
Tekrar teşekkür ederim sayın hocam..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst