پرسش انتقال خودکار اطلاعات

[gilivy71@yahoo.]

سلام دوستان
من یه فایل دارم با 14 شیت شامل 12 شیت به نام شهرستان های مختلف و یک شیت کلی و دیگری خلاصه شهرستان(فایل پیوست هست)
می خوام وقتی که شیت های مربوط به هر شهرستان رو ثبت می کنم اطلاعات در فرم مربوط به خلاصه شهرستان ثبت بشه ولی در کلی نه
توضیح اینکه شیت ها همه مثل هم هستن و از نظر انطباق سطر و ستون مشکلی نداره
میشه راهنمایی کنید
(لینک دانلود فایلhttp://s12.picofile.com/file/8397749..._Mir.xlsm.html)

[gilivy71@yahoo.]

دوستان کسی نمی تونه کمک کنه؟

[M_ExceL]

سلام دوستان
من یه فایل دارم با 14 شیت شامل 12 شیت به نام شهرستان های مختلف و یک شیت کلی و دیگری خلاصه شهرستان(فایل پیوست هست)
می خوام وقتی که شیت های مربوط به هر شهرستان رو ثبت می کنم اطلاعات در فرم مربوط به خلاصه شهرستان ثبت بشه ولی در کلی نه
توضیح اینکه شیت ها همه مثل هم هستن و از نظر انطباق سطر و ستون مشکلی نداره
میشه راهنمایی کنید
(لینک دانلود فایلhttp://s12.picofile.com/file/8397749..._Mir.xlsm.html)

با سلام،
ببینید این راه حل ها کدامشون می تونه بهتر باشه همون رو براتون پیاده کنیم
روش اول - قرار دادن یک کد داخل ماژول شیت های مورد نظر و به محض وارد کردن اطلاعات و کامل شدن ردیف اطلاعات کپی شود
روش دوم - اجرای یک کد در شیت "خلاصه شهرستان ها" و به محض اجرای ان اطلاعات تمام شیت ها به شیت خلاصه منتقل گردد

[gilivy71@yahoo.]

سلام و وقت بخیر
فکر می کنم روش اول بهتر باشه .

[M_ExceL]

سلام و وقت بخیر
فکر می کنم روش اول بهتر باشه .

سلام،

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rng As Range
Dim lstr, lrow As Long

Application.EnableEvents = False

lstr = Sheets("خلاصه شهرستان ها").Cells(Rows.Count, 2).End(3).Row
If lstr = 2 Then
lstr = lstr + 3
Else
lstr = lstr + 1
End If

If Target.Column = 33 Then
lrow = Target.Row
Set rng = Range("b" & lrow & ":ag" & lrow)
countr = WorksheetFunction.CountA(rng)
    If countr = 32 Then
        Sheets("خلاصه شهرستان ها").Range("b" & lstr & ":ag" & lstr).Value = rng.Value
        MsgBox "اطلاعات با موفقيت ثبت گرديد"
    Else
        For i = 2 To 32
            If Cells(lrow, i) = Empty Then
                MsgBox "ستون" & Chr(32) & i & Chr(32) & "خالي است"
            End If
        Next
    End If

End If

Application.EnableEvents = True

End Sub

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

[gilivy71@yahoo.]

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

[M_ExceL]

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

با سلام،
بله درست می فرمایید عجله ای شد و به این مسأله توجه نکرده بودم
می بایست کد نویسی قابل اعتماد تری برای فایلتون انجام شود که مطمئن بشید عملیات لازم انجام می شود
سر فرصت بنده یا دوستان حرفه ای انجمن کد بهتری را اماده خواهیم کرد
با تشکر

[gilivy71@yahoo.]

با سلام،
بله درست می فرمایید عجله ای شد و به این مسأله توجه نکرده بودم
می بایست کد نویسی قابل اعتماد تری برای فایلتون انجام شود که مطمئن بشید عملیات لازم انجام می شود
سر فرصت بنده یا دوستان حرفه ای انجمن کد بهتری را اماده خواهیم کرد
با تشکر

بینهایت سپاس گزارم.

[M_ExceL]

بینهایت سپاس گزارم.

سلام،
فایل پیوست را بررسی کنید

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim rng_s As Range
Dim scr As Range
Dim nrng As Range
Dim c As Range


If Target.Column = 8 Then
    ActiveSheet.Cells.EntireColumn.Hidden = False
    For Each acell In Target.Cells
        If acell.Value <> "" Then
            For Each c In Range("I1:AG1").Cells
                If c.Value <> Range(acell.Address).Value And c.Value <> "" Then
                    MergedInfo = Range(c.Address).MergeArea.Address(0, 0)
                    Range(MergedInfo).EntireColumn.Hidden = True
                ElseIf c.Value = Range(acell.Address).Value And c.Value <> "" Then
                Rng = Range(c.Address).MergeArea.Address(0, 0)
                End If
            Next c
        End If
    Next
End If



If Target.Column = 16 Or Target.Column = 23 Or Target.Column = 29 Then
   
    Set acell = Range("h" & Target.Row)
        If acell.Value <> "" Then
            For Each c In Range("I1:AG1").Cells
                If c.Value <> Range(acell.Address).Value And c.Value <> "" Then
                    MergedInfo = Range(c.Address).MergeArea.Address(0, 0)
                ElseIf c.Value = Range(acell.Address).Value And c.Value <> "" Then
                Rng = Range(c.Address).MergeArea.Address(0, 0)
                End If
            Next c
        End If


If Rng <> Empty Then
    

    endrow = Sheets("خلاصه شهرستان ها").Cells(Rows.Count, 2).End(3).Row
    
    If endrow = 2 Then
    endrow = endrow + 3
    Else
    endrow = endrow + 1
    End If
    

   
    rcount = Range(Rng).Columns.Count
    rng_t = Range(Rng).Offset(Target.Row - 1, 0).Address(0, 0)
    Set rng_s = Range(rng_t).Resize(1, rcount)
   
    
    Set nrng = Range("b" & rng_s.Row & ":g" & rng_s.Row & "," & rng_s.Address(0, 0))
    
    
    
        For Each scr In nrng
            If scr <> "" Then
            
                With scr.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
                End With
                b = True
                
            Else
            
            scr.Select
                With scr.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 255
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                b = False
                MsgBox " ستون" + Str(scr.Column) + " خالي است"
                Exit For
            
           
            End If
        Next
        
    If b = True Then
    
    
    Sheets("خلاصه شهرستان ها").Range("b" & endrow & ":ac" & endrow).Value = Range("b" & rng_s.Row & ":ac" & rng_s.Row).Value
    MsgBox "اطلاعات با موفقيت ثبت گرديد"
    End If
    
   
End If


End If
End Sub

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

[gilivy71@yahoo.]

سلام و وقت بخیر
با خطای زیر مواجه میشه آقای مهندس

[M_ExceL]

سلام و وقت بخیر
با خطای زیر مواجه میشه آقای مهندس
[ATTACH=CONFIG]21007[/ATTACH]

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

[gilivy71@yahoo.]

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

[M_ExceL]

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

فایل جدید پیوست گردید بررسی کنید

[gilivy71@yahoo.]

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

[M_ExceL]

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

بله در پست شماره 5 در این خصوص اشاره ای داشتم
شما بفرمایید که مقدار کدام فیلد در شیت تکراری وارد نمی شود تا بنده بر اساس اون مجدد اصلاح کنم