طباعة بطريقة معينة

[ريان أحمد]

السلام عليكم بدون إطالة الشرح في المرفق وجزاكم الله كل خير

ف.rar

[يوسف عطا]

ياريت لو كنت شرحت المطلوب داخل المشاركة بالإضافة للمرفق

[الـعيدروس]

السلام عليكم

تفضل جرب هذا الكود

Sub Ali_Trn()

Dim sh As Worksheet

Dim S As Worksheet

Dim r

Set sh = ورقة1

Set S = ورقة2

c = 1

rc = sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For r = 2 To 1000

If Not IsEmpty(S.Cells(r, 1)) Then

sh.Cells(rc, c) = S.Cells(r, 1)

c = c + 1

If c = 4 Then c = 1: rc = rc + 1

End If

Next

With sh

.Select

ER = WorksheetFunction.CountA(.Range("A:C")) + 1

Z = "A2:C" & ER

.Range(Z).PrintPreview

End With

End Sub

[ريان أحمد]

Set sh = ورقة1

Set S = ورقة2

مشكلفة في هذا الجزء أنا أستعمل إكسل نسخة فرنسية يعني 0Feuil3 Feuil2 Feuil11

--------------------------------------

الأخ يوسف عطا

الشرح في المرفق بأكثر دقة

tt.rar

[الـعيدروس]

السلام عليكم

عدلت مسمى الاوراق حسب طلبك

tt_1.rar

[ريان أحمد]

أخي عباد الكود يقوم بمعاينة قبل الطباعة للورقة t

ولا يقوم بتحويل البيانات والكود لا يعمل

[ريان أحمد]

up

[الـعيدروس]

السلام عليكم

لاادري ان كنت فهمت طلبك بالشكل الصحيح

لاكن جرب هذا الكود

عله ماتريد

Sub Ali_Trn()

Dim sh As Worksheet

Dim S As Worksheet

Dim rt As Range, Rn As Range

Set sh = Feuil1

Set S = Feuil2

Dim Ar_1(), Ar_2()

Dim CC, q, cx, AA

Static D%

Dim C%, TT%, I%, x%

Dim QQ$

Dim REE As Variant

Dim Z As String

CC = S.Cells(Rows.Count, 1).End(xlUp).Row

TT = 0: q = 0

For I = 1 To CC

If CStr(Cells(I, 1)) <> Empty Then

ReDim Preserve Ar_1(0 To C)

Ar_1(C) = S.Cells(I, 1).Row

FF = FF & "," & S.Cells(I, 1).Address(False, False)

C = C + 1

D = D + 1

End If

Next

For Each rt In sh.Range("A2:C24")

q = q + 1

If Val(q) = Val(D) + 1 Then Exit For

If CStr(sh.Cells(rt.Row, rt.Column)) <> Empty Then

ReDim Preserve Ar_2(0 To cx)

Ar_2(cx) = "'" & sh.Name & "'" & "!" & rt.Address(False, False)

QQ = Ar_2(cx)

x = Ar_1(TT)

S.Cells(x, 2) = Range(QQ)

S.Cells(x, 2).Offset(0, -1).Resize(, 7).Borders.Color = RGB(0, 0, 0)

cx = cx + 1

End If

TT = TT + 1

Next

With S

Application.ScreenUpdating = False

QW = .Cells(Rows.Count, 1).End(xlUp).Row

For Each Rn In .Range(.Cells([A2].End(xlDown).Row, 1), .Cells([A1500].End(xlUp).Row, 1))

If Rn.Value = "" Then

Rn.EntireRow.Hidden = True

End If

Next

Application.ScreenUpdating = True

ER = WorksheetFunction.CountA(.Range("A:B")) + 1

ZZ = "A9:G" & QW

Z1 = "B9:G" & QW

Debug.Print ZZ

.PageSetup.PrintArea = ZZ

.Range(ZZ).PrintPreview

.UsedRange.EntireRow.Hidden = False

.PageSetup.PrintArea = ""

.Range(Z1) = ""

End With

D = 0

Erase Ar_1

Erase Ar_2

End Sub

[ريان أحمد]

السلام عليكم

شكرا جزيلا سأجرب الكود وسأتصل بك بعدها