عند ظهور كلمة معينة .. يكتب عمود جديد

[Alttear]

السلام عليكم :

اخواني الاعزاء .. اريد ترتيب احد الأعمدة في ملف اكسل

بحيث عندما تظهر كلمة معينة في احدى الاسطر .. تنقل و ما تحتها الى عامود جديد ..

هل هذا ممكن ؟؟

[الـعيدروس]

السلام عليكم

ارفاق مثال وبه شرح مبسط

اكيد ممكن

[رامي الخبيري]

السلام عليكم أخي الكريم

الصراحة . . دي أول مرة في حياتي أكتب كود . . لذلك هتلاقيه قمة البدائية

لكن حبيت أساعد

و أكيد أحد العباقرة هنا سيفيد أكثر

تقبل تحياتي

1-ST.zip

[أبو حنــــين]

السلام عليكم

هل تقصد بهذه الطريقة

تعديل.rar

تم تعديل يناير 15, 2013 بواسطه أبو حنين

[Alttear]

شكرا لكم اخواني الاعزاء

الملف المرفق يوضح ما أريد .. مع الشكر الخاص

[Alttear]

UP

[رجب جاويش]

تفضل أخى

Sub ragab()

Dim cl As Range

Dim arr() As Variant

LR = [A1000].End(xlUp).Row

T = 2: x = 2

'====================================

On Error Resume Next

For Each cl In Range("A1:A" & LR)

If IsDate(cl) Then

Cells(1, T) = cl: T = T + 1

End If

Next

'====================================

For Each cl In Range("A2:A" & LR)

If Not IsDate(cl) Then

i = i + 1

ReDim Preserve arr(i)

arr(i - 1) = cl

Else

Cells(2, x).Resize(i) = Application.WorksheetFunction.Transpose(arr)

x = x + 1: Erase arr: i = 0

End If

Next

Cells(2, x).Resize(i) = Application.WorksheetFunction.Transpose(arr)

End Sub

نسخ متعدد.rar

[رامي الخبيري]

بسم الله ما شاء الله عليك أخي رجب

الواحد كل ما يشوف الأكواد الرائعة دي . . . بفكر أني مكملش في موضوع vb ده

سلمت يداك

تحياتي

أخوك رامي

[رجب جاويش]

أخى الفاضل / رامى

جزاك الله كل خير أخى الفاضل على هذه الكلمات الطيبة

واعلم أخى الفاضل

أنه قبل دخولى هذا المنتدى لم أكن أعلم أى شئ عن الأكواد

ولكن بمتابعة اساتذة هذا المنتدى بدأت أتعلم منهم

وما زلت أتعلم منهم الكثير

والأمر يحتاج الصبر منى ومنك حتى نصل الى مستوى متقدم ان شاء الله

كل الشكر والتحية لجميع الأساتذة الذين نتعلم منهم كل يوم

[Alttear]

تفضل أخى

Sub ragab()

Dim cl As Range

Dim arr() As Variant

LR = [A1000].End(xlUp).Row

T = 2: x = 2

'====================================

On Error Resume Next

For Each cl In Range("A1:A" & LR)

If IsDate(cl) Then

Cells(1, T) = cl: T = T + 1

End If

Next

'====================================

For Each cl In Range("A2:A" & LR)

If Not IsDate(cl) Then

i = i + 1

ReDim Preserve arr(i)

arr(i - 1) = cl

Else

Cells(2, x).Resize(i) = Application.WorksheetFunction.Transpose(arr)

x = x + 1: Erase arr: i = 0

End If

Next

Cells(2, x).Resize(i) = Application.WorksheetFunction.Transpose(arr)

End Sub

شكرا لك استاذي الكريم

الملف يعمل بشكل جيد ,, بارك الله بك

التاريخ المكتوب لدي بهذه الصيغة 1.1.2013

لو سمحت جعل التاريخ الذي ينقل بهذه الصيغة 1.1.2013 بدلا من 1/1/2013

و لك جزيل الشكر

[رجب جاويش]

تفضل أخى

نسخ متعدد.rar

[Alttear]

تفضل أخى

شكرا أخي الكريم

لكن لا اعلم لما لا يعمل معي

مرفق الملف

نسخ متعدد.rar

[رجب جاويش]

تفضل أخى

نسخ متعدد.rar

[رامي الخبيري]

تحياتي لك أخي الكريم رجب

و جزاك الله خيرا على كلماتك المشجعة . . .

[Alttear]

تفضل أخى

بارك الله بك أخي الكريم

و لكن المشكلة مازالت قائمة

عندما انسخ البيانات الى الملف

يتوقف عن العمل

بيانات النسخ.rar

[رجب جاويش]

أخى الفاضل

سبب حدوث هذه المشكلة

هو ادخال التاريخ بصورة غير صحيحة

جرب ادخال التاريخ بصورة صحيحة مثل 17/9/2009 مثلا

سوف يعمل الكود بطريقة صحيحة ان شاء الله

[Alttear]

أخى الفاضل

سبب حدوث هذه المشكلة

هو ادخال التاريخ بصورة غير صحيحة

جرب ادخال التاريخ بصورة صحيحة مثل 17/9/2009 مثلا

سوف يعمل الكود بطريقة صحيحة ان شاء الله

بارك الله بك أخي الكريم

بالفعل المشكلة كانت بادخالي الخاطئ للتاريخ

شكرا جزيلا على الملف الرائع

بارك الله بك