بحث عن رقم العمود ثم الترحيل اليه

[ابو منذر عبد الله]

السلام عليم

اريد المساعدة في تعديل على كود يقوم بالترحيل من شيت لشيت و هذا بالبحث عن اسم العمود ليقوم بالترحيل اليه و جزاكم الله خيرا

تقارير (2).xlsm

[محمد هشام.]

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

اسماء الاعمدة غير متطابقة  ... حاول توضح طلبك اكثر او وضع نمودج للنتيجة المتوقعة لكي نستطيع مساعدتك

[ابو منذر عبد الله]

أخي

المطلوب هو رأس العمود حيث يتم الإدخال و الترحيل يكون في الشيت الآخر ( الارشيف) إلى العمود حسب اسمه 

مثال : رقم العمود في شيت الادخال يكون 1 مثلا فإن الترحيل يكون للعمود الذي  تسمية رأسه رقم 1 في شيت الارشيف مع  الحفاض على البيانات المرحلة من قبل في الأعمدة الأخرى و يفرغ ما تم ترحيله في العمود من شيت الادخال

و بار الله فيكم

 

تقارير (2).xlsm

[محمد هشام.]

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

تفضل اخي

 

Sub Find_And_copy()

Dim MH As Worksheet, MH2 As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo

    Set MH = Worksheet____37
    Set MH2 = Worksheet____60
    
    Application.ScreenUpdating = False
    
    'يمكنك تفعيل هدا السطر في حالة الرغبة بحدف البيانات القديمة في نفس العمود المرحل اليه
    'Call Find_And_clear
    
    
    '("H9")تحديد رقم العمود المرحل اليه من شيت ادخال الى شيت ارشيف في الخلية
    For Each c In Application.Intersect(MH.UsedRange, MH.Range("H9"))
       If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
       
       
'رقم صف البحث
Set f = MH2.Rows(9).Find(what:=c.Value, LookIn:=xlValues, _
                                         LookAt:=xlWhole)
            If Not f Is Nothing Then

                Set rngCopy = MH.Range(c.Offset(1, 0), _
                    MH.Cells(Rows.Count, c.Column).End(xlUp))

                Set rngCopyTo = MH2.Cells(Rows.Count, _
                                f.Column).End(xlUp).Offset(1, 0)
        
                rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value

            End If
        End If
    Next c
    
Worksheet____37.Activate
'مسح البيانات المرحلة
'Range("H10:H39").ClearContents
Application.ScreenUpdating = True
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub Find_And_clear()

'("H9") البحث عن رقم العمود بشرط الخلية
'وافراغ البيانات
    
    Dim i           As Integer
    Dim LastRow     As Long
    Dim MyColl      As Collection
    Dim myIterator  As Variant

Set MyColl = New Collection
Application.ScreenUpdating = False
    MyColl.Add Worksheet____37.Range("H9").Value
  

    LastRow = Worksheet____60.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheet____60.Activate
    For i = 6 To 350
        For Each myIterator In MyColl
            If Cells(9, i) = myIterator Then
                Range(Cells(10, i), Cells(LastRow, i)).Select
                         Selection.ClearContents
                         Cells(9, i).Select
              
            End If
        Next
    Next
    
   Worksheet____37.Activate
   Application.ScreenUpdating = True
End Sub

 

 

تقارير (3).xlsm

تم تعديل نوفمبر 5, 2022 بواسطه Mohamed Hicham

[ابو منذر عبد الله]

بارك الله فيك و جزاك الله كل خير