كود لترحيل المدين والدائن وتقرير استدعاء بيانات عن طريق اختيار بيانات التقريروتاريخ فترة

Sub TranserData()

Dim ws As Worksheet, Sh As Worksheet

Dim Lr As Long, Ls As Long, ShNam As String

Dim Arr As Variant, Tmp As Variant, i As Long, j As Long, p As Long

Dim a, b

Set ws = Sheets("الادخال والترحيل")

Lr = ws.Range("C" & Rows.Count).End(3).Row

a = ws.Range("A2"): b = ws.Range("B2")

ShNam = ws.Range("G2")

Set Sh = Sheets(ShNam)

Ls = Sh.Range("B" & Rows.Count).End(3).Row

Arr = ws.Range("A3:F" & Lr).Value

ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

For i = 1 To UBound(Arr, 1)

If Arr(i, 5) > 0 Or Arr(i, 6) > 0 Then

p = p + 1

For j = 1 To UBound(Arr, 2)

Tmp(p, j) = Arr(i, Choose(j, 1, 3, 3, 4, 5, 6))

Tmp(p, 1) = a

Tmp(p, 3) = b

Next

End If

Next

Sh.Range("A" & Ls + 1).Resize(p, UBound(Tmp, 2)).Value = Tmp

End Sub

Sub s()

Dim ws As Worksheet, Sh As Worksheet, ShNam

Dim h As Long, g As Long

Set ws = Sheets("ÇáÇÏÎÇá æÇáÊÑÍíá")

ShNam = ws.Range("g2")

For g = 3 To ws.Range("c" & Rows.Count).End(3).Row

h = Sheets(ShNam).Range("a" & Rows.Count).End(3).Row + 1

If ws.Range("a2") <> "" And ws.Range("b2") <> "" Then

Sheets(ShNam).Cells(h, 1) = ws.Range("a2").Value

Sheets(ShNam).Cells(h, 2) = ws.Cells(g, "c").Value

Sheets(ShNam).Cells(h, 3) = ws.Range("b2").Value

Sheets(ShNam).Cells(h, 4) = ws.Cells(g, "d").Value

Sheets(ShNam).Cells(h, 5) = ws.Cells(g, "e").Value

Sheets(ShNam).Cells(h, 6) = ws.Cells(g, "f").Value

End If

Next g

End Sub

Sub TranserData()

Dim ws As Worksheet, Sh As Worksheet

Dim Lr As Long, Ls As Long, ShNam As String

Dim Arr As Variant, Tmp As Variant, i As Long, j As Long, p As Long

Dim a, b

Set ws = Sheets("ÇáÇÏÎÇá æÇáÊÑÍíá")

Lr = ws.Range("C" & Rows.Count).End(3).Row

a = ws.Range("A2"): b = ws.Range("B2")

ShNam = ws.Range("G2")

Set Sh = Sheets(ShNam)

Arr = ws.Range("A3:F" & Lr).Value

ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

For i = 1 To UBound(Arr, 1)

If Arr(i, 5) > 0 Or Arr(i, 6) > 0 Then

p = p + 1

For j = 1 To UBound(Arr, 2)

Tmp(p, j) = Arr(i, Choose(j, 1, 3, 3, 4, 5, 6))

Tmp(p, 1) = a

Tmp(p, 3) = b

Next

End If

Next

Ls = Sh.Range("a" & Rows.Count).End(3).Row

Sh.Range("A" & Ls + 1).Resize(p, UBound(Tmp, 2)).Value = Tmp

End Sub

Sub saad()

Dim ws As Worksheet, shnam As Worksheet

Dim h As Long, g As Long

Set ws = Sheets("ÇáÊÞÑíÑ")

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

ws.Range("a6:f2000").ClearContents

h = 6

For Each shnam In ActiveWorkbook.Worksheets

If shnam.Name <> "ÇáÇÏÎÇá æÇáÊÑÍíá" And shnam.Name <> "ÇáÊÞÑíÑ" Then

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

For g = 3 To shnam.Range("a" & Rows.Count).End(3).Row

If ws.Range("a3") = "" Then GoTo 1

If shnam.Cells(g, 1) >= ws.Range("a3") Then

1: If ws.Range("b3") = "" Then GoTo 2

If shnam.Cells(g, 1) <= ws.Range("b3") Then

2: If ws.Range("e3") = "" Then GoTo 3

If shnam.Cells(g, 4) = ws.Range("e3") Then

3: If ws.Range("f3") = "" Then GoTo 4

If shnam.Cells(g, 3) = ws.Range("f3") Then

4: '''''''''''''''''''''''''''''''''''''''

ws.Cells(h, 1) = shnam.Name

ws.Cells(h, 2) = shnam.Cells(g, 1)

ws.Cells(h, 3) = shnam.Cells(g, 2)

ws.Cells(h, 4) = shnam.Cells(g, 4)

ws.Cells(h, 5) = shnam.Cells(g, 5)

ws.Cells(h, 6) = shnam.Cells(g, 6)

h = h + 1

End If: End If: End If: End If

Next

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

End If

Next

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

End Sub