Bir aylık gelir gider sayfalarındaki dolu satırları alt alta aktarma

E

Erdinç FIRTINA

Altın Üye
Katılım
14 Şubat 2007
Mesajlar
400
Excel Vers. ve Dili
excel 2003 türkçe
Altın Üyelik Bitiş Tarihi
15-05-2026
Değerli Forum üyeleri;

Bir aylık gelir gider bilançosu ile ilgili düzenlenen her sayfadaki (1-31 arası sayfalardan) ilgili bölümü,
makrolarla bölüm adıyla açılan sayfaya alt alta alınıyor.

Aktarılan verilerde boş satırlar oluyor.

Daha sonra bu sf daki boş satırlar silinerek sıralanıyor

Bu iki işlem yerine, 1-31 sayfalarındaki ilgili bölüme ait dolu satırlar alt alta alınabilir mi?


Örneğin; 1-31 sayfalarındaki B2:E22 arasında olan sadece dolu satırlar alta alta aktarılabilir mi?

Tabi ki; MUTFAK, KIRTASİYE, TEMİZLİK, KİRA, FATURALAR, DİĞER GİDERLER, ARAÇ YAKIT, ARAÇ DİĞER VB ADLI SAYFALARDA DA AYNI İŞLEMİ YAPMAK İSTİYORUM.

YARDIMLARINIZ İÇİN ŞİMDİDEN ÇOK ÇOK TEŞEKKÜRLER!!!
 

Ekli dosyalar

N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Erdinç FIRTINA' Alıntı:
Değerli Forum üyeleri;

Bir aylık gelir gider bilançosu ile ilgili düzenlenen her sayfadaki (1-31 arası sayfalardan) ilgili bölümü,
makrolarla bölüm adıyla açılan sayfaya alt alta alınıyor.

Aktarılan verilerde boş satırlar oluyor.

Daha sonra bu sf daki boş satırlar silinerek sıralanıyor

Bu iki işlem yerine, 1-31 sayfalarındaki ilgili bölüme ait dolu satırlar alt alta alınabilir mi?


Örneğin; 1-31 sayfalarındaki B2:E22 arasında olan sadece dolu satırlar alta alta aktarılabilir mi?

Tabi ki; MUTFAK, KIRTASİYE, TEMİZLİK, KİRA, FATURALAR, DİĞER GİDERLER, ARAÇ YAKIT, ARAÇ DİĞER VB ADLI SAYFALARDA DA AYNI İŞLEMİ YAPMAK İSTİYORUM.

YARDIMLARINIZ İÇİN ŞİMDİDEN ÇOK ÇOK TEŞEKKÜRLER!!!
Genişletmek için tıkla ...
Merhaba
Personel ve Mutfak sayfalarına aktaracak kodları yazdım diğer sayfalar içinde siz yazarsınız
Denermisiniz
Sub PERSONEL()
Dim Satır, x, i As Long, SAYFA, S1 As Worksheet
Set S1 = Sheets("PERSONEL")
S1.Range("A2:E" & Rows.Count).ClearContents
S1.Range("F1").ClearContents
Application.ScreenUpdating = False
Satır = 2
For Each SAYFA In ThisWorkbook.Worksheets
If SAYFA.Index >= Sheets("1").Index And SAYFA.Index <= Sheets("31").Index Then
For x = 2 To 22
If SAYFA.Range("D" & x).Value <> "" Then
S1.Cells(Satır, 2) = SAYFA.Range("B" & x).Value
S1.Cells(Satır, 3) = SAYFA.Range("C" & x).Value
S1.Cells(Satır, 4) = SAYFA.Range("D" & x).Value
S1.Cells(Satır, 5) = SAYFA.Range("E" & x).Value
Satır = Satır + 1
End If
Next x
End If
Next
For i = 2 To [B65536].End(3).Row
If S1.Range("D" & i).Value <> "" Then
S1.Range("F1").Value = S1.Range("D" & i).Value + S1.Range("F1").Value
End If
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
sıra = sıra + 1
Cells(i, 1).Value = sıra
End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı."
End Sub
Sub MUTFAK()
Dim Satır, x, i As Long, SAYFA, S1 As Worksheet
Set S1 = Sheets("MUTFAK")
S1.Range("A2:E" & Rows.Count).ClearContents
S1.Range("F1").ClearContents
Application.ScreenUpdating = False
Satır = 2
For Each SAYFA In ThisWorkbook.Worksheets
If SAYFA.Index >= Sheets("1").Index And SAYFA.Index <= Sheets("31").Index Then
For x = 24 To 33
If SAYFA.Range("D" & x).Value <> "" Then
S1.Cells(Satır, 2) = SAYFA.Range("B" & x).Value
S1.Cells(Satır, 3) = SAYFA.Range("C" & x).Value
S1.Cells(Satır, 4) = SAYFA.Range("D" & x).Value
S1.Cells(Satır, 5) = SAYFA.Range("E" & x).Value
Satır = Satır + 1
End If
Next x
End If
Next
For i = 2 To [B65536].End(3).Row
If S1.Range("D" & i).Value <> "" Then
S1.Range("F1").Value = S1.Range("D" & i).Value + S1.Range("F1").Value
End If
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
sıra = sıra + 1
Cells(i, 1).Value = sıra
End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı."
End Sub
 
Son düzenleme:
N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
numan şamil' Alıntı:
Merhaba
Personel ve Mutfak sayfalarına aktaracak kodları yazdım diğer sayfalar içinde siz yazarsınız
Denermisiniz
Sub PERSONEL()
Dim Satır, x, i As Long, SAYFA, S1 As Worksheet
Set S1 = Sheets("PERSONEL")
S1.Range("A2:E" & Rows.Count).ClearContents
S1.Range("F1").ClearContents
Application.ScreenUpdating = False
Satır = 2
For Each SAYFA In ThisWorkbook.Worksheets
If SAYFA.Index >= Sheets("1").Index And SAYFA.Index <= Sheets("31").Index Then
For x = 2 To 22
If SAYFA.Range("D" & x).Value <> "" Then
S1.Cells(Satır, 2) = SAYFA.Range("B" & x).Value
S1.Cells(Satır, 3) = SAYFA.Range("C" & x).Value
S1.Cells(Satır, 4) = SAYFA.Range("D" & x).Value
S1.Cells(Satır, 5) = SAYFA.Range("E" & x).Value
Satır = Satır + 1
End If
Next x
End If
Next
For i = 2 To [B65536].End(3).Row
If S1.Range("D" & i).Value <> "" Then
S1.Range("F1").Value = S1.Range("D" & i).Value + S1.Range("F1").Value
End If
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
sıra = sıra + 1
Cells(i, 1).Value = sıra
End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı."
End Sub
Sub MUTFAK()
Dim Satır, x, i As Long, SAYFA, S1 As Worksheet
Set S1 = Sheets("MUTFAK")
S1.Range("A2:E" & Rows.Count).ClearContents
S1.Range("F1").ClearContents
Application.ScreenUpdating = False
Satır = 2
For Each SAYFA In ThisWorkbook.Worksheets
If SAYFA.Index >= Sheets("1").Index And SAYFA.Index <= Sheets("31").Index Then
For x = 24 To 33
If SAYFA.Range("D" & x).Value <> "" Then
S1.Cells(Satır, 2) = SAYFA.Range("B" & x).Value
S1.Cells(Satır, 3) = SAYFA.Range("C" & x).Value
S1.Cells(Satır, 4) = SAYFA.Range("D" & x).Value
S1.Cells(Satır, 5) = SAYFA.Range("E" & x).Value
Satır = Satır + 1
End If
Next x
End If
Next
For i = 2 To [B65536].End(3).Row
If S1.Range("D" & i).Value <> "" Then
S1.Range("F1").Value = S1.Range("D" & i).Value + S1.Range("F1").Value
End If
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
sıra = sıra + 1
Cells(i, 1).Value = sıra
End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı."
End Sub
Genişletmek için tıkla ...
kodlar güncellenmiştir.
 
E

Erdinç FIRTINA

Altın Üye
Katılım
14 Şubat 2007
Mesajlar
400
Excel Vers. ve Dili
excel 2003 türkçe
Altın Üyelik Bitiş Tarihi
15-05-2026
numan şamil' Alıntı:
kodlar güncellenmiştir.
Genişletmek için tıkla ...
Sayın numan şamil çok çok teşekkür ederim. Hemen bakıp kontrol edeceğim. Takıldığım bir yer olursa tekrar yardım isteyebilirim.

Her şey için çok teşekkürler!!!

Sayın numan şamil,

veri sayfalarında yani 1-31 arası sayfalarda A-E arasındaki verileri ilgili sayfalara aktarıyor. Ancak,, veri sayfalarında G-K arasındaki verileri ilgili sayfalara aktaramadım. Kodlarda değişiklik yapmaya çalıştım ama maalesef beceremedim. Müsait olduğunuzda bir bakabilir misiniz?

Yardımlarınız için şimdiden çok çok teşekkürler!!!
 

Ekli dosyalar

Son düzenleme:
N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Erdinç FIRTINA' Alıntı:
Sayın numan şamil çok çok teşekkür ederim. Hemen bakıp kontrol edeceğim. Takıldığım bir yer olursa tekrar yardım isteyebilirim.

Her şey için çok teşekkürler!!!

Sayın numan şamil,

veri sayfalarında yani 1-31 arası sayfalarda A-E arasındaki verileri ilgili sayfalara aktarıyor. Ancak,, veri sayfalarında G-K arasındaki verileri ilgili sayfalara aktaramadım. Kodlarda değişiklik yapmaya çalıştım ama maalesef beceremedim. Müsait olduğunuzda bir bakabilir misiniz?

Yardımlarınız için şimdiden çok çok teşekkürler!!!
Genişletmek için tıkla ...
Araç yakıt kodlarını aşağıdaki gibi düzenlermisniz
Sub ARAÇ_YAKIT()
Dim Satır, x, i As Long, SAYFA, S1 As Worksheet
Set S1 = Sheets("ARAÇ YAKIT")
S1.Range("A2:E" & Rows.Count).ClearContents
S1.Range("F1").ClearContents
Application.ScreenUpdating = False
Satır = 2
For Each SAYFA In ThisWorkbook.Worksheets
If SAYFA.Index >= Sheets("1").Index And SAYFA.Index <= Sheets("31").Index Then
For x = 2 To 11
If SAYFA.Range("J" & x).Value <> "" Then
S1.Cells(Satır, 2) = SAYFA.Range("H" & x).Value
S1.Cells(Satır, 3) = SAYFA.Range("I" & x).Value
S1.Cells(Satır, 4) = SAYFA.Range("J" & x).Value
S1.Cells(Satır, 5) = SAYFA.Range("K" & x).Value
Satır = Satır + 1
End If
Next x
End If
Next
For i = 2 To [B65536].End(3).Row
If S1.Range("D" & i).Value <> "" Then
S1.Range("F1").Value = S1.Range("D" & i).Value + S1.Range("F1").Value
End If
If Cells(i, 2).Value = "" Then
Cells(i, 1).Value = ""
Else
sıra = sıra + 1
Cells(i, 1).Value = sıra
End If
Next i
Application.ScreenUpdating = True
MsgBox "işlem tamamlandı."
End Sub
 
N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,231
Excel Vers. ve Dili
Ofis 2013 Türkçe
Rica ederim. İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst