تبدیل اعداد و لیست کردن انها

[ali.b]

با سلام و خسته نباشید
من یک فرم طراحی کردم که برای تعیین میزان رضایت از گزینه های مورد نظر در سلول اون عدد 1 رو وارد میکنن و وقتی دکمه فرم جدید رو میزنم اطلاعات در یک شیت کپی و محتویات فرم اولیه خودکار پاک میشه و یک فایل جداگانه هست که شماره واحدهایی که این فرم رو پرکردن رو یاداشت میکنه.
حالا میخوام طوری فرمول بندی بشه که مثلا وقتی نوشتم موتورخانه 1 رضایت متوسط در فایل جداگانه در قسمت موتورخانه 1، شماره اون اتاق رو بنویسه و برحسب تعداد تکرار شماره اتاق رنگش تغییر کنهبرگه نظرسنجی.xlsm
فایلش رو گذاشتم کسی می تونه کمکی کنه

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[Amir Ghasemiyan]

سلام دوست عزيز
بفرماييد اين فايل خدمت شما

[ali.b]

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

[ali.b]

تو این فایل نمونه اعداد خودشون بر حسب تکرار مرتب میشن

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

من از فایل چیزی متوجه نشدم ولی برداشتم اینه که منظورت همچین فایلی باشه

[Amir Ghasemiyan]

من از فایل چیزی متوجه نشدم ولی برداشتم اینه که منظورت همچین فایلی باشه

نه مهدي جان. ايشون براي من توضيح دادن. دارم براشون درست ميكنم

[Amir Ghasemiyan]

خب دوست عزيز، با كمك هاي جناب امين خان اسماعيلي عزيز بالاخره تونستم فايل مورد نظرتون رو تهيه كنم
بفرماييد خدمت شما. سوالي بود در خدمتم

[ali.b]

فقط میتونم بگم واقعا ممنونم

فقط ی مشکلی هست اینه اگه به جای شماره اتاق هیچی ننویسم کار نمیکنه
If room = 0 Then Exit Sub
ایجا رو چکار کنم؟

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

Sub Macro1()
Application.ScreenUpdating = False

Dim vote As Range
Dim room As Integer
Dim i As Integer
Dim TotalVote(30) As Integer
Dim cel As String

Sheets("Orginal").Select
room = Range("D2").Value
If room = 0 Then GoTo a

For Each vote In Range("C5:G35")
    If vote.Value = 1 Then
        TotalVote(vote.row - 5) = vote.Column - 2
    End If
Next vote

Sheets("result").Select
Range("O" & room) = Range("O" & room) + 1
For i = 0 To 30
    If TotalVote(i) <> 0 Then
        cel = Cells(i + 3, TotalVote(i) + 9)
        If cel = "" Then
            cel = room
        ElseIf Not findroom(Cells(i + 3, TotalVote(i) + 9), room) Then
            cel = cel & "-" & room
        End If
        Cells(i + 3, TotalVote(i) + 9) = cel
    End If
    Cells(i + 3, TotalVote(i) + 9) = sortedarray(Cells(i + 3, TotalVote(i) + 9))
Next i
a:
Call colorise

Sheets("Orginal").Select
    Range("A2:G35").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.count)
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Sheets("Orginal").Select
    Range("D2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("F2").Select
    Selection.ClearContents
    Range("G2").Select
    Selection.ClearContents
    Range("C5:G35").Select
    Selection.ClearContents
    Range("D2").Select
    ActiveWorkbook.Save
    
Application.ScreenUpdating = True
End Sub 

[ali.b]

مشکل شماره نداشتن اتاق حل شد اما محسبات اشتباه میشه
وقتی شماره اتاق نباشه میره سمت a: و درسته اما اگه شماره اتاق باشه دیگه نمیره کار اصلی رو کنه یره همون a: رو نگاه میکنه