تجميع اطلاعات چند شيت

[gha3emi]

سلام
چند تا شيت با اسامي مشخص داريم كه توي هر كدوم از اونها به تعداد نامشخصي اطلاعات درج شده در سطر و ستونهاي مختلف
خواستم ببينم ميشه شيتي تجميع داشت كه حاوي تمام اطلاعات شيت هاي ديگه باشه مثلا اگه شيت 1 پنج سطر و شيت 2 هفت سطر پرشده داره اطلاعات در شيت تجميع شامل همه 12 سطر اون دوتا شيت باشه
ماكرو يا كد vb
ممنون

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[abootorab]

سلام
چند تا شيت با اسامي مشخص داريم كه توي هر كدوم از اونها به تعداد نامشخصي اطلاعات درج شده در سطر و ستونهاي مختلف
خواستم ببينم ميشه شيتي تجميع داشت كه حاوي تمام اطلاعات شيت هاي ديگه باشه مثلا اگه شيت 1 پنج سطر و شيت 2 هفت سطر پرشده داره اطلاعات در شيت تجميع شامل همه 12 سطر اون دوتا شيت باشه
ماكرو يا كد vb
ممنون

با درود
خب میتونید یه شیت با عنوان تجمیع داشته باشین و سپس از شیتهای مورد نظرتون سطرهایی که حاوی اطلاعات هستن کپی بگیرن و به آخرین سطر از شیت تجمیع که خالی هست کپی کنید، اگه فایل نمونه هم بذارین بهتر میشه کمکتون کرد.

[gha3emi]

سلام
تعداد شيتها زياده و دفعاتي كه بايد اينكار انجام بشه هم زياد تعداد ركوردهاي كه وارد ميشه هم متغيره خيلي زياد نه ولي تغيير مي كنه
يك نمونه فايل مي فرستم يك نگاه بهش بندازيد بي زحمت

[امين اسماعيلي]

ba drod bazam babate type finglish mazerat ,harchand in mabhas motmaenan ghablan bahsesh shode ama vase akharin bar ye nemone code mizarim ba tavajo be file dostemon,ye button to sheet tajamoeton mizarin masalan command button21 va codesh mishe in , darzemn code haro ghashang tahlil kon bebin chi mige , chera neveshte shode

Option Explicit
Private Sub CommandButton21_Click()
With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
If Sheet1.Range("A2").Value <> "" Then
Dim lastrow As Long
lastrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheet1.Range("A2:D" & lastrow).ClearContents
End If


Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.CodeName <> "Sheet1" Then
  With ws
    .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheet1.Cells(Rows.Count, "A").End(xlUp).Offset(1)
  End With
  End If
Next ws

Sheet1.Activate
With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

[gha3emi]

سلام ممنون بابت زحمتي كه كشيديد
متاسفانه من تو Vb مبتديم ولي خوب تونستم بفهمم چي كار كرديد
حالا يك سوال
اگه بخوام تو شيت تجمع فقط سطرهاي كپي بشن كه حتما فيلد نام در اون شيتها پر شده باشه و اگه خالي باشه اون سطر رو انتقال نده چي؟
ميدونم واسه اونهاي كه vb بلدن كاري نداره ولي من مبتديم

[gha3emi]

سلام
در مورد سوال بالا كسي نظري نداشت

[gha3emi]

كمك

[majid_mx4]

كمك

با سلام

فایل ضمیمه برای کپی کردن ردیفهایی که دارای کد و اسامی می باشد ارائه میگردد.

با تشکر میر

[gha3emi]

سلام خيلي لطف كرديد
يك سوال ديگه
تو اين كدي كه براتو مي فرستم ما يك محدوده از شيت ها رو براي لاك كردن انتخاب مي كنيم
حالا اگه بخوايم مثلا اون سلولها رو با يك رنگ خاص پر كنيم از چه كدي بايد استفاده كنيم
For Each sh In ActiveWorkbook.Worksheets
With sh
.Unprotect ("1234")
.Select
.Cells.Select
Selection.Locked = False
Selection.FormulaHidden = False
.Range(mahdude).Select
Selection.Locked = True
Selection.FormulaHidden = True
.Protect ("1234"), DrawingObjects:=True, Contents:=True, Scenarios:=True
.EnableSelection = xlUnlockedCells
End With