Excelde bir çok sayfandan veriyi tek sayfada birleştirmek vba kodu arıyorum.

[Kemter]

Esselamunaleykum arkadaşlar vba kodu lazım fakat benim vba bilgim olmadığından forumadaki örnek kodlardan birşeyler denk gelirse copyla yapıştırla hal ederim diye düşündüm. Neticede işin içinden çıkamadım.
Sizlerden yardım rica ediyorum. Sorunum Sheet1'den sheet7 .... devamı gelirse bu sayfalardan B7,D7,F7,D2 satırlarındaki verileri web sayfasına önce sheet1 sonra onun altına sheet2 sonra ne kadar sheet sayfası olursa alt alta devam ederek aktardığından eskisini silerek yenisini aktarmasını istiyorum. Acizane dilim bu kadar döndü örnek dosya ektedir. El-yardımlarınızı rica ediyorum. Şimdiden Rabbim hepinizden razı olsun.

 

[mesuttasar]

Selamlar (eğer soruyu yanlış anlamadıysam) aşağıdaki kodları boş bir modüle kopyalayıp çalıştırırmısınız?

Sub deneme()
Dim a As Integer
Dim i, web_son, k, l As Integer
Dim web As Worksheet
a = Worksheets.Count
Set web = Sheets("web")
For i = 1 To a
If Sheets(i).Name = "Web" Then GoTo 10
k = Sheets(i).[d65536].End(3).Row
If k = 6 Then GoTo 10
For l = 7 To k
web_son = web.[a65536].End(3).Row + 1
web.Cells(web_son, 1) = Sheets(i).Cells(l, 2)
web.Cells(web_son, 2) = Sheets(i).Cells(l, 4)
web.Cells(web_son, 3) = Sheets(i).Cells(l, 6)
web.Cells(web_son, 4) = Sheets(i).Cells(2, 4)
Next l
10
Next i
Rows(k).ClearContents
End Sub

 

[hasanyaprak]

Mesuttasar Bey Merhaba,
Baştan ilk sayfa ile hücreye sayı girerek belirleyeceğim aralıkta(Mesela baştan 1-5 arası) kopyalanacak sayfaların (B8 : D50) hücre arasını kopyalayarak "Satınalma" adındaki sayfamda belirlenen aralığa(Mesala C10) alt alta yazması mümkün müdür? Kopyalanacak aralıkta filtre ile süzme var. Gizli kısımlar da kopyalanmasın istiyorum. Yardım ederseniz çok sevinirim. Şimdiden teşekkürler

 

[askm]

Örnek dosyanızı eklerseniz yardımcı olabiliriz. Tabiki sadece mesut beyin yardım etmesini istemiyorsanız.

 

[hasanyaprak]

CommandButton23_Click()

sifre = "1234hy"
a = InputBox("Şifre Girin", "Şifre")
If a <> sifre Then
MsgBox "Şifre hatalı"
Exit Sub
Else
MsgBox "Şifre doğru"

ANS = MsgBox("Bu safyadaki bilgiler silinecek ve tüm listeler aktarılacak, ONAYLIYOR MUSUNUZ?", vbYesNo)
If ANS = vbYes Then

Dim Sh As Worksheet
Set Sh = ActiveSheet
yol = ThisWorkbook.Path
isim = Sh.Range("Y1").Value
'Y1 DE 5 YAZILI

Dim i As Integer, sat As Long, sat2 As Long

'Tümü sayfasını komple siliyoruz.
Sheets("SATINALMA_GENEL_LİSTE").Range("K9:X50").ClearContents

'İŞLEMİ BEKLETME.
Application.Wait Now + TimeValue("00:00:01")

'SATINALMAYI SEÇİYORUZ.
Sheets("SATINALMA_GENEL_LİSTE").Select
Application.ScreenUpdating = False

'kopyalanacak satır numarası.
sat2 = 9

'KOPYALANACAK SAYFA ARALIĞI.
For i = 1 To isim
sat = Sheets(i).Cells(100, "BV").End(xlUp).Row

'KOPYALANACAK ARALIK.
Sheets(i).Range("H8:R50" & sat).Copy
'YAPIŞTIRILACK HÜCRE.
Range("BV" & sat2).PasteSpecial xlPasteValuesAndNumberFormats

Sheets("SATINALMA_GENEL_LİSTE").Select
Sheets("SATINALMA_GENEL_LİSTE").Range("BV9:CF55").Select
Selection.Copy
Sheets("SATINALMA_GENEL_LİSTE").Select
Range("K9").Select
Selection.PasteSpecial Paste:=xlPasteValues, OPERATION:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False
sat2 = sat2 + sat + 1
Next i
Application.ScreenUpdating = True


MsgBox "İşlem Tamamlanmıştır.", vbOKOnly + vbInformation, "İŞLEM BİTTİ"

End If
End If
End Sub


Bu şekilde bir makrom var çalışıyor ama aralıklı kopyalama yapıyor. Yardımınızı rica ederim.

Merhaba,
Baştan ilk sayfa ile hücreye sayı girerek belirleyeceğim aralıkta(Mesela baştan 1-5 arası) kopyalanacak sayfaların (H8 : R50) hücre arasını kopyalayarak "SATINALMA_GENEL_LİSTE" adındaki sayfamda belirlenen aralığa(Mesala K9) alt alta yazması mümkün müdür? Kopyalanacak aralıkta filtre ile süzme var. Filtreli kısımlar da kopyalanmasın istiyorum. Yardım ederseniz çok sevinirim. Şimdiden teşekkürler"

*Dosya eklemeyi anlayamadığım için ekleyemedim.