• DİKKAT

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

Sütun Silme

C

cinarbx

Katılım
6 Temmuz 2022
Mesajlar
50
Excel Vers. ve Dili
2019
Makroyu çalıştırdığımda bulunan sayfada "S" sütunu "AK" sütunu ve "AL" sütunu hariç diğer sütunları silen bir vba kodu nasıl olabilir acaba ? sildikten sonra bu 3 kolonu yan yana A B C kolonuna gelmesi gerek
 
Merhaba,
işinizi görür umarım.
Kod: 
Sub Makro1()
    Columns("T:AJ").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:R").Select
    Selection.Delete Shift:=xlToLeft
End Sub
Kolay gelsin
 
Tevfik_Kursun' Alıntı:
Merhaba,
işinizi görür umarım.
Kod: 
Sub Makro1()
    Columns("T:AJ").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:R").Select
    Selection.Delete Shift:=xlToLeft
End Sub
Kolay gelsin
Genişletmek için tıkla ...


AL sütunundan sonra da veriler Mevcut onların da tamamının silinmesini istiyorum.
Bir diğer konu da yazmış olduğunuz kod çalışıyor sırasıyla S sütununu A ya AK yi B ye ve AL yi C sütununa getiriyor evet bu işlemi yaptıkdan sonra B ve C hücresindeki verilerin yerlerinin de değişmesi gerekiyor.
 
Merhaba,
İlk mesajınızı yazdıktan sonra okumadığınızı düşünüyorum.
Kod: 
Sub Makro2()
    Columns("S:S").Select
    Selection.Copy
    Columns("A:A").Select
    ActiveSheet.Paste
    
    Columns("AL:AL").Select
    Selection.Copy
    Columns("B:B").Select
    ActiveSheet.Paste
    
    Columns("AK:AK").Select
    Selection.Copy
    Columns("C:C").Select
    ActiveSheet.Paste
    
    Columns("D:ZZ").Select
    Selection.Delete Shift:=xlToLeft
    Application.CutCopyMode = False
End Sub
 
Tevfik_Kursun' Alıntı:
Merhaba,
İlk mesajınızı yazdıktan sonra okumadığınızı düşünüyorum.
Kod: 
Sub Makro2()
    Columns("S:S").Select
    Selection.Copy
    Columns("A:A").Select
    ActiveSheet.Paste
  
    Columns("AL:AL").Select
    Selection.Copy
    Columns("B:B").Select
    ActiveSheet.Paste
  
    Columns("AK:AK").Select
    Selection.Copy
    Columns("C:C").Select
    ActiveSheet.Paste
  
    Columns("D:ZZ").Select
    Selection.Delete Shift:=xlToLeft
    Application.CutCopyMode = False
End Sub
Genişletmek için tıkla ...



Öncelikle teşekkürr ederim zahmetiniz için ekte paylaştığım dosyaya bakınız ben bu yolla makro kaydederek yaptım.

Sizden ricam ekteki dosyayı ben çalıştırmak istediğimde açık olan excel sayfaları donuyor bunun sebebi belkide fazla hücre tarıyor diye olabilir sizden ricam dosyayı çalıştırıp sizde de donma yapıyor mu yapmıyorsa nasıl bir çıktı veriyor ekrana bunu benimle paylaşır mısınız?


deneme.xlsm

drive.google.com drive.google.com
 
Alternatif kod.
Kod: 
Sub test()
Application.ScreenUpdating = False
c = Cells(1, Columns.Count).End(1).Column

For i = 1 To c
    If Cells(1, i).Column <> 19 And Cells(1, i).Column <> 37 And Cells(1, i).Column <> 38 Then
        Cells(1, i).Clear
    End If
Next i

Rows(1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete

Columns("C:C").Cut
Columns("B:B").Insert Shift:=xlToRight

sonA = Cells(Rows.Count, "A").End(3).Row
For i = sonA To 2 Step -1
    If Cells(i, "B").Value = 0 Then
        Rows(i).Delete
    End If
Next i

Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Ayrıca https://excel.web.tr/threads/veri-aktarimi.202417/ bu konudaki paylaşım için geri dönüş yapmadınız.
 
AdemCan' Alıntı:
Alternatif kod.
Kod: 
Sub test()
Application.ScreenUpdating = False
c = Cells(1, Columns.Count).End(1).Column

For i = 1 To c
    If Cells(1, i).Column <> 19 And Cells(1, i).Column <> 37 And Cells(1, i).Column <> 38 Then
        Cells(1, i).Clear
    End If
Next i

Rows(1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete

Columns("C:C").Cut
Columns("B:B").Insert Shift:=xlToRight

sonA = Cells(Rows.Count, "A").End(3).Row
For i = sonA To 2 Step -1
    If Cells(i, "B").Value = 0 Then
        Rows(i).Delete
    End If
Next i

Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Ayrıca https://excel.web.tr/threads/veri-aktarimi.202417/ bu konudaki paylaşım için geri dönüş yapmadınız.
Genişletmek için tıkla ...




Teşekkürler emeğinize sağlık önceki kod da bu kod da çok iyi çalışamakta teşekkür ederim takrardan.
 
AdemCan' Alıntı:
Rica ederim.
Genişletmek için tıkla ...


Şöyle bir şey mümkün müdür acaba anlatıyorum:

Elimde A1 hücresinden BS753 hücresine kadar bağzı hücreleri dolu bağzı hücreleri boş olmak üzere sayfa adı Veri olan bir tablo mevcut üstteki kod gereksiz verileri sildikten sonra benim istediğim 3 veri sütununu bırakıyor ya ben makroyu çalıştırdığımda bu 3 sütun bir yan sayfada Sonuc adındaki sayfada gözükse ?


Yani kodu veri sayfasındaki verilere göre işleyip kalan 3 sütunu Sonuc sayfasına yazacak
 
Kodu güncelledim.
Bi hatırlatma yapmak istiyorum. Sütun silme işlemi çözüldüğü için yeni sorularınızı yeni konu açarak sormanız forum kullanıcıları açısından daha uygun olacaktır.
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Veri"): Set s2 = Sheets("Sonuç")

c = s1.Cells(1, Columns.Count).End(1).Column

For i = 1 To c
    If s1.Cells(1, i).Column <> 19 And s1.Cells(1, i).Column <> 37 And s1.Cells(1, i).Column <> 38 Then
        s1.Cells(1, i).Clear
    End If
Next i

s1.Rows(1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete

s1.Columns("C:C").Cut
s1.Columns("B:B").Insert Shift:=xlToRight

sonA = s1.Cells(Rows.Count, "A").End(3).Row
For i = sonA To 2 Step -1
    If s1.Cells(i, "B").Value = 0 Then
        s1.Rows(i).Delete
    End If
Next i
sonA = s1.Cells(Rows.Count, "A").End(3).Row

son = s2.Cells(Rows.Count, "A").End(3).Row
s2.Range("A1:C" & son).Clear
s1.Range("A1:C" & sonA).Copy s2.Range("A1")

s1.Cells.EntireColumn.AutoFit
s2.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
 
AdemCan' Alıntı:
Kodu güncelledim.
Bi hatırlatma yapmak istiyorum. Sütun silme işlemi çözüldüğü için yeni sorularınızı yeni konu açarak sormanız forum kullanıcıları açısından daha uygun olacaktır.
Kod: 
Sub test()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Veri"): Set s2 = Sheets("Sonuç")

c = s1.Cells(1, Columns.Count).End(1).Column

For i = 1 To c
    If s1.Cells(1, i).Column <> 19 And s1.Cells(1, i).Column <> 37 And s1.Cells(1, i).Column <> 38 Then
        s1.Cells(1, i).Clear
    End If
Next i

s1.Rows(1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete

s1.Columns("C:C").Cut
s1.Columns("B:B").Insert Shift:=xlToRight

sonA = s1.Cells(Rows.Count, "A").End(3).Row
For i = sonA To 2 Step -1
    If s1.Cells(i, "B").Value = 0 Then
        s1.Rows(i).Delete
    End If
Next i
sonA = s1.Cells(Rows.Count, "A").End(3).Row

son = s2.Cells(Rows.Count, "A").End(3).Row
s2.Range("A1:C" & son).Clear
s1.Range("A1:C" & sonA).Copy s2.Range("A1")

s1.Cells.EntireColumn.AutoFit
s2.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...



docs.google.com

deneme.xlsm

Veri Buyer i.d.,Supplier i.d.,transmission no. old,transmission no. new,Message date,Buyer Organization,Org. Name Customer,Buyer plant i.d.,Plant Name,Unloading Point,Point of Consumption,warehouse,Packaging type 1,filling quantity 1,Packaging type 2,filling quantity 2,Packaging type 3,filling q...
docs.google.com docs.google.com

merhabalar ekte dosya bıraktım istediğim şeyi tekrar daha açık ifade ediyorum belki üstteki mesajda tam ifade edememiş olabilirim :

veri sayfasında bütün veriler bulunuyor sonuc sayfasındaki makroya bastığım anda silme işlemi ve B sütunuyla C sütunundaki yer değiştirme işlemi yapılacak ve bu 3 sütun Sonuc sayfasında gözükecek. İstediğim şey bu yardımcı olursanız sevinirim. Sizin yazmış olduğunuz kod yine veri sayfasına yazdırıyor.
 
Merhaba, ben kod içinde sayfa ismini Sonuç olarak belirttim, dosyanızdaki sayfa ismine göre
Set s2 = Sheets("Sonuç") satırını
Set s2 = Sheets("Sonuc") olarak değiştiriniz.
 
AdemCan' Alıntı:
Merhaba, ben kod içinde sayfa ismini Sonuç olarak belirttim, dosyanızdaki sayfa ismine göre
Set s2 = Sheets("Sonuç") satırını
Set s2 = Sheets("Sonuc") olarak değiştiriniz.
Genişletmek için tıkla ...



Dediğinizi yaptım ve kod sorunsuz çalıştı üzerinde biraz daha ilerleme yapıp bir döngü içinde şartlı kod yazmak istedim ekte bıraktığım dosyada da görebilirsiniz ancak bir türlü if değeri çalışmadı bu konuda yardımcı olur musunuz?

drive.google.com

deneme.xlsm

drive.google.com drive.google.com
 
Merhaba, 10 numaralı mesajda belirttiğim gibi yeni sorularınız için yeni konu açınız.
AdemCan' Alıntı:
Bi hatırlatma yapmak istiyorum. Sütun silme işlemi çözüldüğü için yeni sorularınızı yeni konu açarak sormanız forum kullanıcıları açısından daha uygun olacaktır.
Genişletmek için tıkla ...
 
Aynı proje fakat, konu başlıkları farklı olduğu için forum kullanıcılarının faydalanması açısından, farklı konuların yeni başlıklarda açılması daha uygun olur.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst