سوال در رابطه با کپی کردن سطرهای چند شیت در اکسل

**امين اسماعيلي** · 2014/04/18, 15:03

با درود
اینم باز یه سوال تکراریه
Create a summary worksheet from all worksheets (جمع کردن اطلاعات تمامی شیت ها در یک شیت)
تو این تاپیک کل اطلاعات از شیت های مختلف یه جا جمع میشه. حالا کافی شما تقریبا شبیه همین خیلی ساده تر عمل کنی تمام

**hamedh** · 2014/04/18, 15:29

ممنون دوست عزیز از راهنمایی شما
متاسفانه موضوع من کمی فرق داره.
من فقط 1 سطر از همه شیت ها را می خواهم کپی کنم
تاپیکی هم که شما فرمودید کار نمیکنه متاسفانه

**امين اسماعيلي** · 2014/04/18, 20:00

باد درود
نمیدونم چرا تلاش نکردین . اما کد هارو راتون گذاشتم توضیحاتی هم در بخش های کد ها براتون نوشتم . فرض کنید در سه ستون ما نام و نام خانوادگی و کد ملی رو داریم در شیت 1(فرضا در ابتدا خالی) حالا میخوایم از هر چه شیته رنج A2:C7 رو بیاره زیر اینها بزاره . که شما میتونین هر جا رو خواستین عوض کنین . فقط یادتون نره . قبلش اطلاعات شیت جمع اوری پاک میشن و دوباره پر میشن. اگر نمیخواین پاک بشهباید دو خط کد پاک بشه از توی این کد

کد:

Sub SummurizeSheets()
'first deactive the Automatic calculation and screenupdating causing our macro run faster
   With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
Sheet1.Cells.ClearContents
Sheet1.Range("A1:C1").Value = Array("National code", "Name and family name", "Locatction") 'header of columns A , B , C
    Dim ws As Worksheet
        For Each ws In ThisWorkbook.Sheets
    With Sheet1
    lastrow1 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' find the last row in sheet1
        End With
    
           If ws.CodeName <> "Sheet1" And ws.Range("A2").Value <> "" Then ' if the sheet codename is not equal to sheet1 and that sheet have a value in range ("A2") ( is not empty ) then select
        ws.Select
        
       
            Range("A2:C7").Select 'change to specific range that you want
    Selection.Copy
            Sheet1.Select
    Range("A" & lastrow1 + 1).Select ' copy this specific range has been mentioned above in first empty row (lastrow pluse 1
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
             Application.CutCopyMode = False
        End If
    Next ws
    'don't forget to set as defult the calculation and screenupdating
        With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

کد بالا رو توی یه ماژول کپی کن و با یه باتن یا شیپ اجراش کن