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

مساعدة فى عمل كود لجعل البيانات بشكل راسى


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

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

  • 2 weeks later...

اريد الموظف احمد مثلا توضع بياناته اسفل بعض بمعنى من a3 حتى c9 ثم اسفله من d3 حتى f9 ثم اسفله من g3 حتى i8 ثم اسفله j3 حتى l8 وده يتم فى الورقة رقم 2 وفيه شكل موضح ومرفق تعديل يسيط للملف والف الف شكر على متابعة حضرتك استاذنا الغالى

شيت البصمة.xlsm

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

  • أفضل إجابة

1- تبديل اسماء الصفحات الى    Source  و   Targ  لجسن نسخ الكود ولصقه

الكود

Option Explicit

Sub get_data()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Dim s As Worksheet, T As Worksheet
Dim S_rg As Range, Find_rg As Range
Dim Nme$, i%
Dim RoT%, Ro%, m%: m = 3

Set s = Sheets("source"): Set T = Sheets("Targ")

Nme = T.Cells(1, 1)
RoT = T.Cells(Rows.Count, 1).End(3).Row
T.Range("A3").Resize(RoT, 3).Clear
If Nme = vbNullString Then GoTo End_Me

Set Find_rg = s.Columns("M").Find(Nme, lookat:=1)
If Not Find_rg Is Nothing Then
    Ro = Find_rg.Row + 2
    Set S_rg = s.Cells(Ro, 1).CurrentRegion
    
    For i = 1 To 10 Step 3
      S_rg.Cells(1, i).Resize(S_rg.Rows.Count, 3).Copy _
      T.Cells(m, 1)
      m = m + S_rg.Rows.Count
    Next
End If
If m > 3 Then
    With T.Range("A3").CurrentRegion
      .InsertIndent 1
      .Borders.LineStyle = 1
      .Font.Bold = True
      .Font.Size = 14
      .Interior.ColorIndex = 35
    End With
  
End If
End_Me:
  With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .CutCopyMode = False
  End With

End Sub

الملف مرفق

 

Basma Sh.xlsm

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

استاذنا الكبير معلش حاولت اطبق الكود على شيت اخر لاقيت ان البيانات التى يتم نقلها اكبر مما هى عليها فى الشيت الاصلى

ولى طلب بسيط لو امكن ان البيانات التى يتم نسخها فى الورقة targ يا ريت تبدا من الخلية b3

واسف جدا لازعاج حضرتك مرة اخرى

Basma Sh.xlsm

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

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