Ayrı sayfalardaki verileri kopyalama

[solidworks]

https://www.dosyaupload.com/dkK0

LİNKTEKİ EXCEL DOSYASINDA FARKLI SAYFALARDAKİ VERİLERİ SON SAYFADAKİ TOPLAM SAYFASINA GETİRMEK

ÖRNEK

TİP1 DEN KAÇ ADET VAR
TİP2 DEN KAÇ ADET VAR
TÜM SAYFALARDAKİ TİP1 ADETLERİNİ ARAYIP BULUP YAZMASI GEREKİYOR
TÜM SAYFALARDAKİ TİP2 ADETLERİNİ ARAYIP BULUP YAZMASI GEREKİYOR

BUNUN GİBİ 100 ÇEŞİT OLDUĞUNDAN BU İŞİN KOLAY BİR YOLU VARMIDIR.

 

[hoguz2]

Merhaba,

şu makroyu kaydedip calistirin butun calisma sayfalarini bir sayfada toplar.

sonra pivot tablo kullanarak istediginiz verilere bakabilirsiniz.

Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub

 

[solidworks]

Bir hata var sanki

=#başv!*#başv! 47 satırda böyle birşey yazıyor bu nedir

 

[Asri]

Alternatif;

TOPLAM haricinde farklı bir sayfa olmamalıdır.
Tüm sayfaları birleştirir ve adet toplamını alır.
Toplam sayfasını her defasında silip yeniden oluşturur.

https://www.dosyaupload.com/4Wtj

Sub menu()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Call sayfalari_birlestir
   Call Toplam_icin_hazirla
   Call Toplam_Al
   Call Son_Duzenleme
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

Sub Son_Duzenleme()
    Sheets("TOPLAM").Select
    Columns("A:C").Select
    Range("C1").Activate
    Selection.Delete Shift:=xlToLeft
    Columns("A:B").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Tip"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Adet"
    Range("B2").Select
End Sub

Sub Toplam_Al()
    Sheets("TOPLAM").Select
    sonsatir = Cells(Rows.Count, "D").End(3).Row
    ActiveCell.FormulaR1C1 = "=SUMIF(C[-4],RC[-1],C[-3])"
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E" & sonsatir)
    Range("E2:E" & sonsatir).Select
    Columns("E:E").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("E2").Select
    Application.CutCopyMode = False
    Range("E4").Select
End Sub


Sub Toplam_icin_hazirla()
    Sheets("TOPLAM").Select
    Columns("A:B").Select
    Selection.Copy
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Application.CutCopyMode = False
    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft
    sonsatir = Cells(Rows.Count, "D").End(3).Row
    Columns("D:D").Select
    ActiveSheet.Range("$D$1:$D$" & sonsatir).RemoveDuplicates Columns:=1, Header:=xlNo
    ActiveWorkbook.Worksheets("TOPLAM").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TOPLAM").Sort.SortFields.Add Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TOPLAM").Sort
        .SetRange Range("D1:D" & sonsatir)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("D1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E2").Select
End Sub

Sub sayfalari_birlestir()
  If WorksheetExists("TOPLAM") Then Sheets("TOPLAM").Delete
  Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
  newsh.Name = "TOPLAM"
  
  For i = 1 To Sheets.Count
    isim = Sheets(i).Name
    If isim = "TOPLAM" Then GoTo son
    Sheets(isim).Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Range("A2:C" & sonsatir).Select
    Selection.Copy
    Sheets("TOPLAM").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Range("A" & sonsatir + 1).Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
son:
 Next i
    Sheets("TOPLAM").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    Columns("B").Delete
    
    'Columns("A:A").Select
    'ActiveSheet.Range("$A$1:$A$" & sonsatir).RemoveDuplicates Columns:=1, Header:=xlNo
    'Range("A2").Select
End Sub


Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

 

[solidworks]

tam olarak yapamadım

nasıl yapabileceğimi sıra ile yazarsanız sevinirim

 

[Asri]

tam olarak yapamadım

nasıl yapabileceğimi sıra ile yazarsanız sevinirim

Mesajıma dosya linki eklendi.

 

[solidworks]

teşekkürler