سؤال عن ترحيل بيانات إلى ورقة عمل جديدة بشروط

[الحامد الشاكر]

السلام عليكم ورحمة الله وبركاته

يرجى لطفاً فتح الملف المرفق الذي يشرح السؤال

مقدراً إستجابتكم السريعة بما أمكن.

مع فائق الإحترام

خطاب مطابقة.zip

[عبدالله باقشير]

السلام عليكم

اضف هذا الكود مع الدالة الى ملفك

واربطه بزر

Sub kh_AddDate()

Dim sh As Worksheet

Dim MyRng As Range

Dim MyName As String

''''''''''''''''''

Set MyRng = Range("B3:I34")

MyName = Range("K3").Value

'''''''''''''''''''''

If kh_Test_MyChr(MyName) Then Exit Sub

Range("K3").ClearContents

''''''''''''''''

Set sh = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))

''''''''''''''''

sh.Name = MyName

MyRng.Copy

With sh.Range("B3")

    .PasteSpecial xlPasteColumnWidths

    .PasteSpecial xlPasteFormats

    .PasteSpecial xlPasteValues

End With

''''''''''''''''''''''

Application.CutCopyMode = False

Set sh = Nothing

Set MyRng = Nothing

End Sub



Function kh_Test_MyChr(khString As Variant) As Boolean

Dim MySh As Worksheet

Dim MyChArray, MyChr

Dim S As Integer, R As Integer

S = Len(Trim(khString))

If S > 31 Or S = 0 Then

    MsgBox "حروف الاسم قد تكون اصغر من 1  او اكبر من 31", 524288 + 1048576 + 16, "اسم مرفوض"

    kh_Test_MyChr = True

    Exit Function

End If

'------------------------------------

MyChArray = Array("/", "*", ":", "؟", "?", "[", "]")

For Each MyChr In MyChArray

    If InStr(1, khString, MyChr, 1) <> 0 Then

        MsgBox "حروف الاسم تحتوي على الحرف " & Chr(10) & Chr(10) & Chr(9) & MyChr & Chr(10) & Chr(10) & "وهو من الاحرف الممنوعة  " & "/ * :  ؟ [ ]", 524288 + 1048576 + 16, "حرف ممنوع"

        kh_Test_MyChr = True

        Exit Function

    End If

Next

'------------------------------------

For Each MySh In ActiveWorkbook.Sheets

    If UCase(Trim(MySh.Name)) = UCase(Trim(khString)) Then

        MsgBox "الاسم مكرر ", 524288 + 1048576 + 16, "اسم مكرر"

        kh_Test_MyChr = True

        Exit Function

    End If

Next

End Function

المرفق 2003

خطاب مطابقة.rar

[الحامد الشاكر]

الأخ عبد الله

الشـــــــــــــــــــكر الجزيل للحل الرائع ولتعاونك

جعله الله في ميزان حسناتك

هل لي بإستفسار: إن ورقة العمل التي يتم منها الترحيل لها إعدادات للطباعة ولكنها لا تنسحب على الأوراق الجديدة المرحلة إليها

فهل من حل

جزاك الله خيراً ويسر أمورك

[عبدالله باقشير]

الأخ عبد الله

الشـــــــــــــــــــكر الجزيل للحل الرائع ولتعاونك

جعله الله في ميزان حسناتك

هل لي بإستفسار: إن ورقة العمل التي يتم منها الترحيل لها إعدادات للطباعة ولكنها لا تنسحب على الأوراق الجديدة المرحلة إليها

فهل من حل

جزاك الله خيراً ويسر أمورك

تعرف تسجل كود ؟

اذا الاجابة نعم

وانت في ورقة الترحيل

اضغط تسجيل كود

من القائمة

ملف

اعدادات الصفحة

غير اي شي

ثم اعمل ايقاف التسجيل

ستحصل على كود باعدادات الورقة

مثل هذا:

Sub ماكرو1()

'

' ماكرو2 ماكرو

' الماكرو مسجل ‎02/10/2012 بواسطة ‎BaQuShEeR

'

    With ActiveSheet.PageSetup

        .PrintTitleRows = ""

        .PrintTitleColumns = ""

    End With

    ActiveSheet.PageSetup.PrintArea = "$B$3:$I$34"

    With ActiveSheet.PageSetup

        .LeftHeader = ""

        .CenterHeader = "&G"

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = "&D"

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0.196850393700787)

        .RightMargin = Application.InchesToPoints(0.393700787401575)

        .TopMargin = Application.InchesToPoints(3.1496062992126)

        .BottomMargin = Application.InchesToPoints(0.748031496062992)

        .HeaderMargin = Application.InchesToPoints(0.31496062992126)

        .FooterMargin = Application.InchesToPoints(0.31496062992126)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintNoComments

        .CenterHorizontally = True

        .CenterVertically = False

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA4

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = 108

        .PrintErrors = xlPrintErrorsDisplayed

    End With

End Sub

ثم غير اسم الكود مثلا : kh_PageSetup ضع الاسم هذا في الكود kh_AddDate بعد السطر

Application.CutCopyMode = False

حاول واخبرنا النتيجة

[الحامد الشاكر]

فكرة ولا اروع

الحل باكمله رائـــــــــــــــــــــع ( تمت الإجابة )

جزاك الله خيراً اخي عبد الله

[الحامد الشاكر]

الأخ اعبد الله

يرجى لطفاً إعطاء حل لمشكلة الترحيل بشكل خاطئ عندما يكون هناك خلايا مدموجة مع بعضها

مع فائق الإحترام

[عبدالله باقشير]

الأخ اعبد الله

يرجى لطفاً إعطاء حل لمشكلة الترحيل بشكل خاطئ عندما يكون هناك خلايا مدموجة مع بعضها

مع فائق الإحترام

لماذا الدمج ؟؟

بدلا من الدمج في الخلايا

من القائمة

تنسيق

خلايا

محاذاة

محاذاة النص

افقي

توسيط ممتد عبر التحديد

جرب واخبرنا بالنتيجة

[الحامد الشاكر]

صقر يا أخ عبد الله ... جزاك الله خيراً

وعذراً على التأخير

تم تعديل أكتوبر 3, 2012 بواسطه الحامد الشاكر