مشکل کپی اطلاعات یک سطر اکسل در صورت برقراری شرط در شیت دیگر؟سلام دوستان کسی راه حلی برای این مشکل داره؟هرچی پست بود جستجو کردم چیزی گیرم نیامد.فایل نمونه
-
-
sigpic
-
تشکر مهدی جان
تشکر مهدی جانخوب متوجه نشدم اگر نمونه ای باشه معرفی کنی ممنون می شممن اکسل بلدم ولی نه زیاد.....کامنت
-
ممنون از راهنمایی شما...
من روش کار میکنم خبر میدم....بازهم ممنون از وقتی که گذاشتی...کامنت
-
ابتدا شیت هایی که ایجاد کردی جز شیت اصلی حذف کن
با alt+f11 وارد محیط vba میشی
یک ماژول ایجاد کن
و کد زیر رو کپی کن
کد PHP:Sub test()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Sheet1.Range("A2:A13000")
Dim ws, m
For Each ws In Worksheets
a = c.Value
m = 0
If ws.Name = c.Offset(0, 4).Value Then
m = 1
Exit For
End If
Next
If (m <> 0) Then
Else
If c.Offset(0, 4) <> "" Then
Sheets.Add After:=Sheets(Sheets.Count)
Application.ActiveSheet.Name = c.Offset(0, 4).Value
Dim n
n = 0
Dim cb As Range
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 0).Value = "ÑÏíÝ"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 1).Value = "ÊÇÑíÎ"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 2).Value = "ÔãÇÑå ÓäÏ"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 3).Value = "ÔÑÍ"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 4).Value = "ÔãÇÑå æ˜ÇáÊ"
For Each cb In Sheet1.Range("A3:A13000")
If cb.Offset(0, 4).Value = c.Offset(0, 4).Value And cb.Offset(0, 4) <> "" Then
n = n + 1
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 0).Value = n
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 1).Value = cb.Offset(0, 0).Text
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 2).Value = cb.Offset(0, 1).Text
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 3).Value = cb.Offset(0, 2).Text
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 4).Value = cb.Offset(0, 3).Text
End If
Next cb
End If
End If
Next c
End Sub
sigpic
کامنت
-
سلام مهدی جان راستش من تاحالا از ماژول تو اکسل استفاده نکردم خیلی زحمت کشیدی برنامشو نوشتی ولی هرچی کلنجار رفتم نتونستم ازش تو اکسل استفاده کنم.
اگه ممکنه لینکی برای نحوه استفاده از ماژول برام بزاری یا روی نمونه برام بگی ممنون می شم.
نمونه هرچی باشه خوبه....کامنت
-
فایل پیوست رو مشاهده کنید
sigpic
کامنت
-
سلام آقا مهدی بازم تشکر....
دقیقا قبل از چک کردن پیام بلاخره اجرای ماکرو رو یاد گرفتم، حالا شما هم زحمت کشیدی فایلشو فرستادی...
بعد اجرا یک مشکل وجود داره اینکه با اضافه شدن اطلاعات به فایل اصلی و اجرای ماکرو دیگه اطلاعات جدید تو شیت ها ثبت نمیشه؟؟؟؟؟؟
مگر اینکه همه شیت ها پاک بشه دوباره ماکرو اجرا بشه....
راحی هست!!!!!!!!!!!!!!!!!!!!!!!!!
بازهم از راهنمایی و وقتی که گذاشتی تشکر میکنم.کامنت
-
دو خط پایین رو با گذاشتن یک کاما ' غیر فعال کن
کد PHP:Sheets.Add After:=Sheets(Sheets.Count)
Application.ActiveSheet.Name = c.Offset(0, 4).Value
sigpic
کامنت
-
منظورتو متوجه نشدم وقتی کاما اضافه میکنم دستور قرمز و اجرا نمیشه...کامنت
-
سلام...
اینکارو انجام دادم ولی خطای زیر میده
run time error 9کامنت
-
دستور زیر؟؟؟
اشکال کار چیه؟؟؟
کد PHP:Sub test()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Sheet1.Range("A2:A13000")
Dim ws, m
For Each ws In Worksheets
a = c.Value
m = 0
If ws.Name = c.Offset(0, 4).Value Then
m = 1
Exit For
End If
Next
If (m <> 0) Then
Else
If c.Offset(0, 4) <> "" Then
'Sheets.Add After:=Sheets(Sheets.Count)
'Application.ActiveSheet.Name = c.Offset(0, 4).Value
Dim n
n = 0
Dim cb As Range
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 0).Value = "radif"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 1).Value = "tarikh"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 2).Value = "sanad"""
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 3).Value = "sharh"
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(0, 4).Value = "vekalat"
For Each cb In Sheet1.Range("A3:A13000")
If cb.Offset(0, 4).Value = c.Offset(0, 4).Value And cb.Offset(0, 4) <> "" Then
n = n + 1
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 0).Value = n
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 1).Value = cb.Offset(0, 0).Text
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 2).Value = cb.Offset(0, 1).Text
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 3).Value = cb.Offset(0, 2).Text
Sheets(c.Offset(0, 4).Value).Range("a2").Offset(n, 4).Value = cb.Offset(0, 3).Text
End If
Next cb
End If
End If
Next c
End Sub
کامنت
-
دوستان کسی هست که در مورد این مشکل راه حلی داشته باشه؟؟؟؟؟؟؟؟؟؟؟سلام آقا مهدی بازم تشکر....
دقیقا قبل از چک کردن پیام بلاخره اجرای ماکرو رو یاد گرفتم، حالا شما هم زحمت کشیدی فایلشو فرستادی...
بعد اجرا یک مشکل وجود داره اینکه با اضافه شدن اطلاعات به فایل اصلی و اجرای ماکرو دیگه اطلاعات جدید تو شیت ها ثبت نمیشه؟؟؟؟؟؟
مگر اینکه همه شیت ها پاک بشه دوباره ماکرو اجرا بشه....
راحی هست!!!!!!!!!!!!!!!!!!!!!!!!!
بازهم از راهنمایی و وقتی که گذاشتی تشکر میکنم.
خیلی جستجو کردم ولی به نتیجه نرسیدم................کامنت
کامنت