دستور if براساس رنگ نوشته های داخل سلول

[master]

سلام
یه ستونی هست که داخلش مبلغ هست
برداشت ها با قرمز و واریز ها با رنگ آبی نوشته شده
میخوام یه ستون اضافه کنم کنار این ستون و واریز و برداشت ها جدا بشن برن توی دو تا ستون
دستوری میخوام با if بنویسم که چک کنه اگه عدد قرمز بود عدد رو ببره سلول متناظر ستون کناری مثلا اگه a12 هست ببره b12
فقط توی قسمت شرطش موندم چطوری رنگ رو چک کنم؟
ضمنا اینکه مثلا کد همون رنگ رو چطوری بدست بیارم؟(اینو از لحاظ پرسیدم چون توی چند تا فایلی که دارم همه ابی و قرمز هستن ولی ممکنه کد ابی این فایل با اون یکی فرق کنه چطوری میشه این مشکل رو حل کرد؟)
با تشکر

[amir_ts]

با سلام
این کد را امتحان کنید...
در صورتی که در ستون A رنگ عدد قرمز باشد به ستون B منتقل میشود.
رنگ ها رو هم با تغییر عدد 3 مشاهده کنید.

[LEFT]
Sub test()
Dim i As Integer
           For i = 1 To 100
              If Range("a" & i).Font.ColorIndex = 3 Then
              Range("a" & i).Offset(, 1) = Range("a" & i)
              Range("a" & i).Offset(, 1).Font.ColorIndex = 3
              Range("a" & i) = ""
              End If
           Next
End Sub
 
[/LEFT]

[iranweld]

با سلام

در فایل پیوست کد هر رنگ در ستون C درج میگردد سپس با سورت کردن میتوانید داده های مختلف را سورت نمایید

Sub test()

z1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row

For i = 2 To z1

Range("c" & i) = Range("b" & i).Font.ColorIndex

Next

End Sub 

[rahi_feri]

یه نمونه بفرستید

[master]

سلام
نمونه فایل رو پیوست کردم
الان که چک کردم دیدم یه ستون داره که داخل واریز یا برداشت نوشته شده و میشه براساس اون هم از هم جدا بشن
کاری که من نیاز دارم برا این فایل
اول اینکه تاریخ ها از بزگ به کوچی هستن میخوام از کوچک به بزرگ مرتب بشن(بالای جدول اول ماه باشه و اخر ماه بره پایین)
بعد اون ستون واریز و برداشت هم از جدا بشن برن توی دو تا ستون
و در اخر اون ستون که نوع تراکنش رو نوشته حذف بشه

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

[amir_ts]

با سلام
این کد کارهای مورد نیاز شما را انجام میده....
فقط به دلیل حذف ستون یک بار از کد ها در شیت استفاده کنید.

[LEFT]
Sub test()
Dim i, lr As Integer
lr = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Columns("B:B").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("b2:E283")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
    
           For i = 1 To lr
              If Range("d" & i).Font.ColorIndex = 3 Then
                    Range("d" & i).Offset(, 1) = Range("d" & i)
                    Range("d" & i).Font.ColorIndex = 0
                    Range("d" & i).Offset(, 1).Font.ColorIndex = 3
                    Range("d" & i) = ""
              End If
           Next
         
Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
  Columns("B:B").ColumnWidth = 13
      Application.ScreenUpdating = True
      Range("a1").Select
End Sub
 
[/LEFT]

[iranweld]

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

[master]

سلام
با توجه به راهنمایی دوستان و اون چیزی که تو ذهن خودم بود تقریبا مشکل حل شد
چیزی که من میخواستم ماکرویی هست که تو فایل پیوست شده نوشتم و با Ctrl+h اجرا میشه
فقط با اینکه توی خط اول کد زیر رو نوشتم
Application.ScreenUpdating = False
بازم یکم کند هست و با اینکه تعداد سطر ها خیلی زیاد نیست ولی کند اجرا میشه
قبلش که اون کد نبود کلا چند ثانیه اکسل فریز میشد (الانم میشه ولی یکم کمتر هست)

راهی داره سریعتر اجرا بشه؟ مثلا کد بهینه تر بشه؟
با تشکر