ایجاد لیست با تغییر دو پارامتر به صورت خودکار

[sabertb]

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

[M_ExceL]

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

Sub M_excel()

Dim lent, lastf, lasta, lastd As Long
Dim F, A, D As Long

lent = Range("q" & Rows.Count).End(3).Row + 1
Range("q2:s" & lent).ClearContents
lastf = Cells(Rows.Count, 2).End(3).Row
lasta = Cells(Rows.Count, 3).End(3).Row
lastd = Sheets(2).Cells(Rows.Count, 2).End(3).Row

Application.ScreenUpdating = False
For F = 3 To lastf
For A = 3 To lasta
lastr = Range("q" & Rows.Count).End(3).Row + 1
Range("q" & lastr).End(3).Offset(1, 0) = Cells(F, 2)
Range("r" & lastr).End(3).Offset(1, 0) = Cells(A, 3)
For D = 3 To lastd
If Cells(F, 2) = Sheets(2).Cells(D, 2) And Cells(A, 3) = Sheets(2).Cells(D, 3) Then
Range("s" & lastr) = Range("s" & lastr) + Sheets(2).Cells(D, 4)
End If
Next
Next
Next
Application.ScreenUpdating = True

End Sub

[sabertb]

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

sub m_excel()

dim lent, lastf, lasta, lastd as long
dim f, a, d as long

lent = range("q" & rows.count).end(3).row + 1
range("q2:s" & lent).clearcontents
lastf = cells(rows.count, 2).end(3).row
lasta = cells(rows.count, 3).end(3).row
lastd = sheets(2).cells(rows.count, 2).end(3).row

application.screenupdating = false
for f = 3 to lastf
for a = 3 to lasta
lastr = range("q" & rows.count).end(3).row + 1
range("q" & lastr).end(3).offset(1, 0) = cells(f, 2)
range("r" & lastr).end(3).offset(1, 0) = cells(a, 3)
for d = 3 to lastd
if cells(f, 2) = sheets(2).cells(d, 2) and cells(a, 3) = sheets(2).cells(d, 3) then
range("s" & lastr) = range("s" & lastr) + sheets(2).cells(d, 4)
end if
next
next
next
application.screenupdating = true

end sub
ممنون خیلی عالی بود ولی در واقع همون چیزی که تو فایل توضیح دادم رو به همون ترتیبات لازم دارم یعنی یکی یکی پارامتر ها را جایگزین کنه و نتایج حاصل شده رو ازسلول l2 تا n2 رو در جدول آبی رو بروش حتما کپی کنه .
برای این این گونه لازم دارم که در فایل اصلیم که 30 مگابایت حجم داره دیتا ها داخل شبکه هستن و فقط روکش دست ماست و ما می خوایم پارامتر ها رو به ترتیب قرار بدیم و نتایج را در جدول مربوطه کپی کنیم

[sabertb]

ممنون میشم شبیه موردی که لازم دارم برام کد نویسی شو راهنمایی کنید ! خودم میتونم هر کدوم از پارامتر ها رو تنهایی قرار بدم با ماکرو و اطلاعاتش رو کپی کنم ولی اینکه یکی از پارامترهای نام افراد را بزره بعد همه ابزار ها را برای اون قرار بده یکی یکی و جواب ها را هم به ترتیب کپی کنه در جدول و بعد بره سراغ نفر بعدی این رو وارد نیستم ، در ضمن دیتا های من با تاریخ روز ثبت میشه د ر جدول می خواستم اگر تاریخ ثبت شده قبلی در جدول با تاریخ روز یکی بود و دوباره روی Bottom کلیک کردم اطلاعات قبلی روز ام پاک شه و جدیدا جایگزین بشه

[M_ExceL]

ممنون میشم شبیه موردی که لازم دارم برام کد نویسی شو راهنمایی کنید ! خودم میتونم هر کدوم از پارامتر ها رو تنهایی قرار بدم با ماکرو و اطلاعاتش رو کپی کنم ولی اینکه یکی از پارامترهای نام افراد را بزره بعد همه ابزار ها را برای اون قرار بده یکی یکی و جواب ها را هم به ترتیب کپی کنه در جدول و بعد بره سراغ نفر بعدی این رو وارد نیستم ، در ضمن دیتا های من با تاریخ روز ثبت میشه د ر جدول می خواستم اگر تاریخ ثبت شده قبلی در جدول با تاریخ روز یکی بود و دوباره روی Bottom کلیک کردم اطلاعات قبلی روز ام پاک شه و جدیدا جایگزین بشه
سلام،
بفرمایید :

Sub M_excel()
Dim lastf, lasta, lastr As Long
Dim F, A As Long
lastr = Range("q" & Rows.Count).End(3).Row + 1
Range("q2:s" & lastr).ClearContents
lastf = Cells(Rows.Count, 2).End(3).Row
lasta = Cells(Rows.Count, 3).End(3).Row
With Application
.ScreenUpdating = False
For F = 3 To lastf
For A = 3 To lasta
Range("l2") = Cells(F, 2)
Range("m2") = Cells(A, 3)
lastr = Range("q" & Rows.Count).End(3).Row + 1
Range("l2:n2").Copy
Range("q" & lastr & ":s" & lastr).PasteSpecial (xlPasteValues)
Next
Next
.ScreenUpdating = True
.CutCopyMode = False
End With
End Sub