مشکل کپی اطلاعات یک سطر اکسل در صورت برقراری شرط در شیت دیگر

[goblinup]

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

[~M*E*H*D*I~]

درود

میتونی از کد لینک زیر ایده بگیری

کامنت گزاری این کد لططططططططططططططفا ؟ @@

[goblinup]

تشکر مهدی جان

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

[~M*E*H*D*I~]

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

با فرمول این کار ممکن نیست ، لینکی که برات گذاشتم دقیقا کاری که میخوای رو انجام میده فقط کمب باید اصلاحش کنی

[goblinup]

ممنون از راهنمایی شما...

من روش کار میکنم خبر میدم....بازهم ممنون از وقتی که گذاشتی...

[~M*E*H*D*I~]

من روش کار میکنم خبر میدم....بازهم ممنون از وقتی که گذاشتی...

ابتدا شیت هایی که ایجاد کردی جز شیت اصلی حذف کن

با alt+f11 وارد محیط vba میشی

یک ماژول ایجاد کن

و کد زیر رو کپی کن

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 

[goblinup]

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

[~M*E*H*D*I~]

فایل پیوست رو مشاهده کنید

[goblinup]

سلام آقا مهدی بازم تشکر....
دقیقا قبل از چک کردن پیام بلاخره اجرای ماکرو رو یاد گرفتم، حالا شما هم زحمت کشیدی فایلشو فرستادی...
بعد اجرا یک مشکل وجود داره اینکه با اضافه شدن اطلاعات به فایل اصلی و اجرای ماکرو دیگه اطلاعات جدید تو شیت ها ثبت نمیشه؟؟؟؟؟؟
مگر اینکه همه شیت ها پاک بشه دوباره ماکرو اجرا بشه....
راحی هست!!!!!!!!!!!!!!!!!!!!!!!!!
بازهم از راهنمایی و وقتی که گذاشتی تشکر میکنم.

[~M*E*H*D*I~]

دو خط پایین رو با گذاشتن یک کاما ' غیر فعال کن

Sheets.Add After:=Sheets(Sheets.Count)
                        Application.ActiveSheet.Name = c.Offset(0, 4).Value 

[goblinup]

منظورتو متوجه نشدم وقتی کاما اضافه میکنم دستور قرمز و اجرا نمیشه...

[~M*E*H*D*I~]

منظورتو متوجه نشدم وقتی کاما اضافه میکنم دستور قرمز و اجرا نمیشه...

اول هر خطش یک عدد ' بذار

[goblinup]

سلام...
اینکارو انجام دادم ولی خطای زیر میده
run time error 9

[goblinup]

دستور زیر؟؟؟
اشکال کار چیه؟؟؟

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 

[goblinup]

سلام آقا مهدی بازم تشکر....
دقیقا قبل از چک کردن پیام بلاخره اجرای ماکرو رو یاد گرفتم، حالا شما هم زحمت کشیدی فایلشو فرستادی...
بعد اجرا یک مشکل وجود داره اینکه با اضافه شدن اطلاعات به فایل اصلی و اجرای ماکرو دیگه اطلاعات جدید تو شیت ها ثبت نمیشه؟؟؟؟؟؟
مگر اینکه همه شیت ها پاک بشه دوباره ماکرو اجرا بشه....
راحی هست!!!!!!!!!!!!!!!!!!!!!!!!!
بازهم از راهنمایی و وقتی که گذاشتی تشکر میکنم.

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