Ekte örneğini koyduğum çalışmada hangi aya veri girilirse aynı zamanda otomatik depoda toplanmasını istiyorum. Ben dört sütun veri yazdım bu fazla sütun da olabilir. Yardımlarınız için teşekkür ederim.
Veri Depolama
(24/10/2020, 18:12)hegu yazdı: Ekte örneğini koyduğum çalışmada hangi aya veri girilirse aynı zamanda otomatik depoda toplanmasını istiyorum. Ben dört sütun veri yazdım bu fazla sütun da olabilir. Yardımlarınız için teşekkür ederim.
kopyalama makrosu ile hallettim. Bilgi amaçlı örneği yüklüyorum. Farklı bir yol varsa da onu da görmek isterim. teşekkür ederim.
Son Düzenleme: 25/10/2020, 11:04, Düzenleyen: hegu.
(24/10/2020, 18:12)hegu yazdı: hangi aya veri girilirse aynı zamanda otomatik depoda toplanmasını istiyorumMerhaba.
Yukarıdaki yazdığınıza göre sayfada değişiklik olunca aktarması gerekiyor lakin sizin kod Depo sayfasını silip Ay sayfalarındaki verileri kopyalayıp aktarıyor.
istediğiniz veri girincemi yoksa nasıl olacak.
Alttaki gibide olabilir.
Sub SayfaAktar()
Dim syf As Worksheet
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Depo")
.Range("A2:L" & Rows.Count).ClearContents
For Each syf In ThisWorkbook.Sheets
If LCase(syf.Name) <> "depo" Then
If WorksheetFunction.CountA(syf.Range("A2" & Rows.Count)) > 0 Then
syf.Range(syf.Range("A2"), syf.Range("A1").End(xlDown).End(xlToRight)).Copy
.Range("A" & Rows.Count).End(3)(2, 1).PasteSpecial xlValues
End If
End If
Next
End With
MsgBox "islem tamam...", vbInformation, "Bilgi"
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
syf.Range(syf.Range("A2"), syf.Range("A1").End(xlDown).End(xlToRight)).Copy
Eğer satırlar arasında boş olacaksa örneğin Tc sütunucaki satırda boş veri olursa alttaki gibi değiştirilir yukarıdaki kodun.syf.Range("A2" & syf.Range("A" & Rows.Count).End(3).Row).Copy
Yada en iyisi bu.Aktarırken format olarakta aktarır.
Sub SayfaAktar()
Dim syf As Worksheet
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Depo")
.Range("A2" & Rows.Count).ClearContents
For Each syf In ThisWorkbook.Sheets
If LCase(syf.Name) <> "depo" Then
If WorksheetFunction.CountA(syf.Range("A2" & Rows.Count)) > 0 Then
syf.Range("A2" & syf.Range("A" & Rows.Count).End(3).Row).Copy
.Range("A" & Rows.Count).End(3)(2, 1).PasteSpecial xlPasteValuesAndNumberFormats
End If
End If
Next
End With
MsgBox "islem tamam...", vbInformation, "Bilgi"
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
Konuyu Okuyanlar: 1 Ziyaretçi