ترکیب متن سلول ها

[iranweld]

با سلام

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

Sub test()

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



Dim list1 As New Collection

For I = 2 To Z1

If Application.CountIf(Range("A2:A" & Z1), Range("A" & I)) = 1 Then

Range("C" & I) = Range("B" & I)

ElseIf Application.CountIf(Range("A2:A" & Z1), Range("A" & I)) > 1 And Range("A" & I).Interior.ColorIndex <> 4 Then

For J = I To Z1

If Range("A" & I) = Range("A" & J) Then

Range("A" & J).Interior.ColorIndex = 4

list1.Add Range("B" & J)

End If

Next

For K = 1 To list1.Count

XX = XX & "-" & list1.Item(K)

Next

Range("C" & I) = Right(XX, Len(XX) - 1)

Set list1 = Nothing

XX = ""

End If

Next

Range("A2:A" & Z1).Interior.ColorIndex = 0

End Sub 

[fokker]

با سلام و تشکر

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

[iranweld]

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

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

[fokker]

بسیار تشکر

[كامران]

با سلام

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

Sub test()

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



Dim list1 As New Collection

For I = 2 To Z1

If Application.CountIf(Range("A2:A" & Z1), Range("A" & I)) = 1 Then

Range("C" & I) = Range("B" & I)

ElseIf Application.CountIf(Range("A2:A" & Z1), Range("A" & I)) > 1 And Range("A" & I).Interior.ColorIndex <> 4 Then

For J = I To Z1

If Range("A" & I) = Range("A" & J) Then

Range("A" & J).Interior.ColorIndex = 4

list1.Add Range("B" & J)

End If

Next

For K = 1 To list1.Count

XX = XX & "-" & list1.Item(K)

Next

Range("C" & I) = Right(XX, Len(XX) - 1)

Set list1 = Nothing

XX = ""

End If

Next

Range("A2:A" & Z1).Interior.ColorIndex = 0

End Sub 

الحق که میگن دانش انتها نداره و هر چیزی بلد باشی حتما یکی هست که بهترشو بلده چون کد من و کد شما تقریبآ یه کار انجام میده با این تفاوت که مال شما کار رو بهتر انجام میده و با اجازه شما من ازش تو کارای خودم استفاده میکنم
ولی در موردش چند تا سوال دارم اگه ممکنه راهنمائی کنید
1 - چون در این دیتاهای خاص از - در داخل متنها هم استفاده شده اگه بینشون هم - بذاریم قاطی میشه پس من رو سیستم خودم تو اول و آخر اونا از ] و[ استفاده کردم ولی باز هم شکیل نیست حالا سوال اینه با توجه به اینی که vba تابعی داره که میشه باهاش رنگ فونت رو عوض کرد راهی هست که چیزی مثل chr(13) که برا اینتر میذاریم بین متنها چیزی توی خط xx = xx &..... بذاریم که دیتاهائی که از ستون b به c میاد یکی در میون مثلآ سیاه و سفید بشه ؟
2 - من خواستم بعد اینکه کد کارشو انجام داد ستونهای تکراری رو حذف کنم و کردم نتیجه ش هم این شد بعدش وقتی دوباره کد رو اجرا کردم با ستون c مثل ستون خالی برخورد کرد و کلآ دیتاها بهم ریخت پس اگه من بخوام تکراریها رو حذف کنم و بعد خط جدیدی به دیتاهام اضافه کنم و بخوام دوباره کد رو اجرا کنم راهش چیه که به کارهائی که قبلآ کرده دست نزنه و فقط رو جدیدها محاسبه انجام بده ؟
3 - در این مورد خاص چون تعداد ستونها زیاده و کد وقت میخواد تا کارشو انجام بده اکسل تا آخر کار به حالت نو ریسپانس میره و امکان داره آدم خیال کنه اکسل قاطی کرده راهی هست در طول انجام اینکار چیزی نمایش داده بشه که آدم مطمئن باشه برنامه داره کارشو میکنه ؟ (البته میشه چیزی وسط حلقه ها اضافه کرد ولی سرعت کار رو میاره پایین من دنبال یه تنظیمات توی خود اکسل هستم که شاید برا اینکار گذاشته و من بلدش نیستم )

[كامران]

الحق که میگن دانش انتها نداره و هر چیزی بلد باشی حتما یکی هست که بهترشو بلده چون کد من و کد شما تقریبآ یه کار انجام میده با این تفاوت که مال شما کار رو بهتر انجام میده و با اجازه شما من ازش تو کارای خودم استفاده میکنم
ولی در موردش چند تا سوال دارم اگه ممکنه راهنمائی کنید
1 - چون در این دیتاهای خاص از - در داخل متنها هم استفاده شده اگه بینشون هم - بذاریم قاطی میشه پس من رو سیستم خودم تو اول و آخر اونا از ] و[ استفاده کردم ولی باز هم شکیل نیست حالا سوال اینه با توجه به اینی که vba تابعی داره که میشه باهاش رنگ فونت رو عوض کرد راهی هست که چیزی مثل chr(13) که برا اینتر میذاریم بین متنها چیزی توی خط xx = xx &..... بذاریم که دیتاهائی که از ستون b به c میاد یکی در میون مثلآ سیاه و سفید بشه ؟
2 - من خواستم بعد اینکه کد کارشو انجام داد ستونهای تکراری رو حذف کنم و کردم نتیجه ش هم این شد بعدش وقتی دوباره کد رو اجرا کردم با ستون c مثل ستون خالی برخورد کرد و کلآ دیتاها بهم ریخت پس اگه من بخوام تکراریها رو حذف کنم و بعد خط جدیدی به دیتاهام اضافه کنم و بخوام دوباره کد رو اجرا کنم راهش چیه که به کارهائی که قبلآ کرده دست نزنه و فقط رو جدیدها محاسبه انجام بده ؟
3 - در این مورد خاص چون تعداد ستونها زیاده و کد وقت میخواد تا کارشو انجام بده اکسل تا آخر کار به حالت نو ریسپانس میره و امکان داره آدم خیال کنه اکسل قاطی کرده راهی هست در طول انجام اینکار چیزی نمایش داده بشه که آدم مطمئن باشه برنامه داره کارشو میکنه ؟ (البته میشه چیزی وسط حلقه ها اضافه کرد ولی سرعت کار رو میاره پایین من دنبال یه تنظیمات توی خود اکسل هستم که شاید برا اینکار گذاشته و من بلدش نیستم )

جناب iranweld
ممنون میشم اگه جواب سوالاتم رو هم بدید

[iranweld]

با سلام

جناب آقای مهندس کامران

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

در مورد سوال دوم فرمودید ستون ها رو میخواهید حذف کنید یا سطرها رو حذف کنید؟

با یک مثال ساده بفرمایید ممنون میشم

[كامران]

با سلام

جناب آقای مهندس کامران

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

در مورد سوال دوم فرمودید ستون ها رو میخواهید حذف کنید یا سطرها رو حذف کنید؟

با یک مثال ساده بفرمایید ممنون میشم

اشتباه تایپی بود سطرهای ستون a که تکراری هستن منظورم بود ببخشید

[كامران]

فایل کامل

[Amir Ghasemiyan]

بصورت کلی ش این میشه که چکار کنیم تا یه ماکرو خصوصآ اینی که تو تاپیک دوستمون نوشتن وقتی یه بار اجرا شد و روی یه سری دیتا محاسباتی رو انجام داد در اجراهای بعدی کارهائی رو که قبلآ کرده ندیده بگیره و بره سراغ اطلاعات جدید

پ.ن فایل با کدی که نوشتن ایشون رو تو آخرین پست تاپیک میذارم (ظاهرآ اینجا نمیشه ), که میگرده اگه تو ستون a متن تکراری پیدا کرد متن سلول b متناظرشو به متنی که توی اولین سطری ار ستون c که جلوی همون کد ستون a هست میذاره تا اینجا مشکل نداره ولی مشکل از اونجا شروع میشه که ما تکراریهای ستون a رو حذف کنیم و دوباره کد رو اجرا کنیم
اول یکبار ترکیب سلولها رو اجرا کنید و به ستون c دقت کنید بعد حذف رو اجرا کنید و دوباره ترکیب رو اجرا کنید

سلام

با يك تغيير كوچيك فكر كنم نتيجه اي كه نياز داريد رو بتونين بدست بياريد. كافيه خط شش رو به اين صورت اصلاح كنيد:

If Application.CountIf(Range("A2:A" & Z1), Range("A" & I)) = 1 And Range("C" & I) = "" Then

[كامران]

سلام

با يك تغيير كوچيك فكر كنم نتيجه اي كه نياز داريد رو بتونين بدست بياريد. كافيه خط شش رو به اين صورت اصلاح كنيد:

If Application.CountIf(Range("A2:A" & Z1), Range("A" & I)) = 1 And Range("C" & I) = "" Then

تغییر مورد نظر شما رو اعمال کردم کار کرد ولی وقتی بعد همه کارها یه خط جدید با یه کد تکراری اضافه کردم و ماکرو رو اجرا کردم دوباره مشکل خودشو نشون داد

[Amir Ghasemiyan]

تغییر مورد نظر شما رو اعمال کردم کار کرد ولی وقتی بعد همه کارها یه خط جدید با یه کد تکراری اضافه کردم و ماکرو رو اجرا کردم دوباره مشکل خودشو نشون داد

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

یک نمونه بذارید برای مرحله دوم اضافه کردن کدها که بتونم بررسی کنم

[كامران]

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

یک نمونه بذارید برای مرحله دوم اضافه کردن کدها که بتونم بررسی کنم

در اصل این برناه و این جدول مال من نیست من از داده هاش برا یادگیری استفاده کردم و چون ماکروئی که داشت مشکل داشت نشستم و یکی دیگه با آزمون و خطا طراحی کردم که براتون میذارم و ممنون میشم نظرتونو بدونم فقط یه چیزی که کنجکاوم کرده اینه که آیا راهی هست که وقتی ماکرو داره کارشو میکنه و داده ها رو تو یه خونه توی[] جمع میکنه آیا راهی هست که یه متغیر تعریف کرد که داخل 1 سلول هر قسمتی که (در اینجا داخل هر [] ) به یه رنگ در بیاد مثال:[asdf] [asdf] [asdf]