ادغام شیت ها

[alireza123456]

سلام خدمت اساتید
چگونه می توان داده های میزان درآمد شرکت های مختلف را که در چند شیت آمده ، در یک شیت جای داد در حالیکه اسامی یک شرکت می تواند در یک شیت تکراری باشد و یا در شیت دیگری نباشد.

با توجه به حجم زیاد داده ها انجام این کار با ادغام kutools و منوهای اکسل بسیار زمانبر است شاید دوستانی که با کدنویسی آشنا هستند بتوانند کمک کنند

با سپاس

[mohammad_ashooryan]

سلام
با روشی که توی لینک زیر توضیح داده شده اینکار رو انجام دادم.

http://www.contextures.com/xlPivot08.html

فایل پیوست زیر رو ببینید:
R921.xlsx

[alireza123456]

ممنونم
اگه زحمت نیست روشی رو که ارجاع دادید روی نمونه ارسالی توضیح دهید تا مطلب روشنتر شود

[iranweld]

با سلام

فایل ذیل با کدنویسی تهیه گردید. ابتدا یک لیست یونیک از تمامی شماره های موجود در ستون A شیت های موجود در شیت DATA ایجاد شده و سپس جمع هر یک در جلوی آنها قید میگردد

Private Sub CommandButton1_Click()

Sheets("DATA").Columns("A:B").ClearContents



 Dim list1 As New Collection
 
  
 
 On Error Resume Next

For Each Sheet In Worksheets

If Sheet.Name <> "data" Then

Z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row


For I = 1 To Z1

list1.Add Sheet.Range("A" & I), CStr(Sheet.Range("A" & I))

Next


End If

Next Sheet

Sheets("data").Select

Range("B1") = "income"


For I = 1 To list1.Count

Sheets("data").Range("a" & I) = list1.Item(I)

Next

Application.ScreenUpdating = False

Z2 = Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Row

For J = 2 To Z2

For Each Sheet In Worksheets

Z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row


For I = 1 To Z1

If Sheet.Range("A" & I) = Range("A" & J) Then


Sum = Sum + Sheet.Range("B" & I)

End If

Next

Next

Range("B" & J) = Sum
Sum = 0

Next


Application.ScreenUpdating = True

End Sub 

[alireza123456]

ممنونم
اگه زحمت نیست روشی رو که ارجاع دادید روی نمونه ارسالی توضیح دهید تا مطلب روشنتر شود

ممنونم
تونستم انجام بدم از زحمت شما تشکر می کنم

[alireza123456]

از شما استاد گرامی که مانند همیشه از راهنمایی بی نظیر شما استفاده کردم سپاسگزارم

با سلام

فایل ذیل با کدنویسی تهیه گردید. ابتدا یک لیست یونیک از تمامی شماره های موجود در ستون A شیت های موجود در شیت DATA ایجاد شده و سپس جمع هر یک در جلوی آنها قید میگردد

Private Sub CommandButton1_Click()

Sheets("DATA").Columns("A:B").ClearContents



 Dim list1 As New Collection
 
  
 
 On Error Resume Next

For Each Sheet In Worksheets

If Sheet.Name <> "data" Then

Z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row


For I = 1 To Z1

list1.Add Sheet.Range("A" & I), CStr(Sheet.Range("A" & I))

Next


End If

Next Sheet

Sheets("data").Select

Range("B1") = "income"


For I = 1 To list1.Count

Sheets("data").Range("a" & I) = list1.Item(I)

Next

Application.ScreenUpdating = False

Z2 = Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Row

For J = 2 To Z2

For Each Sheet In Worksheets

Z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row


For I = 1 To Z1

If Sheet.Range("A" & I) = Range("A" & J) Then


Sum = Sum + Sheet.Range("B" & I)

End If

Next

Next

Range("B" & J) = Sum
Sum = 0

Next


Application.ScreenUpdating = True

End Sub 

[alireza123456]

با تشکر
از آنجا که برخی از شیت ها ماهانه و برخی سالانه است آیا می توان کدها را به گونه ای تغییر داد که سلول های شیت های ماهانه در 12 ضرب و سپس با شیت های سالانه جمع شوند
به طور مثال 3 شیت اول ماهانه و بقیه سالانه باشند

[iranweld]

نحوه تشخیص شیت ماهانه و سالانه چگونه هست؟

[alireza123456]

با فرض اینکه همه شیت ها غیر از شیت آخر ماهانه است

[iranweld]

برای اینکه شیت ماهانه قابل تشخیص باشد در هر شیت ماهانه در سلول c1 حرف M را قرار دهید

For I = 1 To Z1

If Sheet.Range("A" & I) = Range("A" & J) And LCase(Sheet.Range("C1")) = "m" Then

Sum = Sum + Sheet.Range("B" & I) * 12

ElseIf Sheet.Range("A" & I) = Range("A" & J) Then

Sum = Sum + Sheet.Range("B" & I)

End If 

[iranweld]

روش دیگر:
تجمیع شیت ها در یک شیت و گزارشگیری با پیوت تیبل که این روش از سرعت بالاتری برخوردار است

Private Sub CommandButton1_Click()

Sheets("DATA").Columns("A:C").ClearContents



 For Each Sheet In Worksheets

If Sheet.Name <> "data" Then

z1 = Sheet.Cells(Rows.Count, "A").End(xlUp).Row

z2 = Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Row + 1

Sheet.Range("A2:B" & z1).Copy Destination:=Sheets("DATA").Range("B" & z2)

For i = z2 To z2 + z1 - 2

Range("A" & i) = Sheet.Name

Next

End If

Next Sheet

Sheets("data").Select

Range("a1") = "Sheet.name"

Range("b1") = "address"

Range("c1") = "income"

 ActiveWorkbook.RefreshAll

Application.ScreenUpdating = True

End Sub 

[alireza123456]

سلام خیلی متشکرم
با توجه به اینکه در برخی شیت ها بیش از 500000 ورودی دارم این ماکرو در انجام عملیات کمک بیشتری می کند
در سوالات قبلی نیز علیرغم اجرایی بودن ماکروها حجم بالای داده ها امکان استفاده از آنها را محدود می کرد.

موفق باشید