اذهب الي المحتوي
أوفيسنا

كود استدعاء بيانات مختصره من شيت اخر


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

Required code

Option Explicit

Sub Get_All()
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim LR1 As Single, LR2 As Single
  Dim m As Single, t As Single, x As Single

  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  LR1 = sh1.Cells(Rows.Count, 2).End(3).Row
  LR2 = sh2.Cells(Rows.Count, 1).End(3).Row
m = 2
   If LR1 > 1 Then
     Union(sh1.Range("B2:B" & LR1), _
     sh1.Range("D2:D" & LR1)).ClearContents
   End If
For x = 2 To LR2
    If sh2.Cells(x, 2).MergeCells Then
      t = sh2.Cells(x, 2).MergeArea.Rows.Count
          With sh1.Cells(m, 2)
           .Value = sh2.Cells(x, 2)
           .Offset(, 2) = sh2.Cells(x, 4)
          End With
       x = x + t - 1: m = m + 1
    Else
          With sh1.Cells(m, 2)
            .Value = sh2.Cells(x, 2)
            .Offset(, 2) = sh2.Cells(x, 4)
          End With
      m = m + 1
   End If
Next
End Sub

الملف مرفق

Naser.xlsm

  • Like 2
رابط هذا التعليق
شارك

  • أفضل إجابة

تم التعديل

Option Explicit

Sub GetMe_All()
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim LR1 As Single, LR2 As Single
  Dim m As Single, t As Single, x As Single

  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  LR1 = sh1.Cells(Rows.Count, 2).End(3).Row
  LR2 = sh2.Cells(Rows.Count, 1).End(3).Row
m = 2
   If LR1 > 1 Then
     Union(sh1.Range("A2:A" & LR1), sh1.Range("B2:B" & LR1), _
     sh1.Range("D2:D" & LR1)).ClearContents
   End If
For x = 2 To LR2
    t = sh2.Cells(x, 2).MergeArea.Rows.Count
          With sh1.Cells(m, 2)
           .Offset(, -1) = "From " & x - 1 & " To " & t + x - 2
           .Value = sh2.Cells(x, 2)
           .Offset(, 2) = sh2.Cells(x, 4)
          End With
       x = x + t - 1
    m = m + 1
Next
End Sub

الملف من جديد

 

Naser_1.xlsm

  • Like 2
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information