transfer data from sheet1 to sheet2 vertically based on value of cell

[abdelfattah]

hello
i have sheet1 contains data i would transfer data to sheet2 vertically if value of cell e3 in sheet2 = the brand colored by green in sheet1
before

after

 

[mumps]

Assuming you have the headers in row 5 of Sheet2, try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, FR As Long, cnt As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    Set fnd = srcWS.Range("F:F").Find(desWS.Range("E3"), LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        With srcWS.Range("A" & fnd.Row + 2 & ":A" & LastRow).SpecialCells(xlCellTypeConstants)
            FR = .Areas.Item(1).Row
            cnt = .Areas.Item(1).Cells.Count
            srcWS.Cells(FR + 1, 1).Resize(cnt - 1, 5).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            srcWS.Cells(FR + 1, 7).Resize(cnt - 1, 5).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[abdelfattah]

thanks for this awesome code but i have troubles when i search in this brand 1400r20 is ok but when i search this 1200r20 all the data transfer except row 15 it begins from row 16 and i would when i search new brand it should clear old data

 

[mumps]

Make sure that Sheet1 is the active sheet when you run the macro.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, FR As Long, cnt As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    desWS.UsedRange.Offset(3).ClearContents
    Set fnd = Range("F:F").Find(desWS.Range("E3"), LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        With Range("A" & fnd.Row + 2 & ":A" & LastRow).SpecialCells(xlCellTypeConstants)
            FR = .Areas.Item(1).Row
            cnt = .Areas.Item(1).Cells.Count
            srcWS.Cells(FR + 1, 1).Resize(cnt - 1, 5).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            srcWS.Cells(FR + 1, 7).Resize(cnt - 1, 5).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[abdelfattah]

the problems is still continue image1 when i search 1400r20 this what show no headers and hide cell of search e3

and when i search this 1200r20 it untidily data and highlight old data should deleted and before date 20/02/2020 it doesn't transfer i no know why

 

[mumps]

Do you have headers in Sheet2 - A5:E5 ?

 

[abdelfattah]

no any headers the sheet empty before run the code

 

[mumps]

Make sure that Sheet1 is the active sheet when you run the macro.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, fnd As Range, FR As Long, cnt As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    desWS.UsedRange.Offset(2).ClearContents
    Set fnd = Range("F:F").Find(desWS.Range("E3"), LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        With Range("A" & fnd.Row + 2 & ":A" & LastRow).SpecialCells(xlCellTypeConstants)
            FR = .Areas.Item(1).Row
            cnt = .Areas.Item(1).Cells.Count
            With srcWS
                .Range("A4:E4").Copy desWS.Range("A5")
                .Cells(FR + 1, 1).Resize(cnt - 1, 5).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
                .Cells(FR + 1, 7).Resize(cnt - 1, 5).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            End With
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[abdelfattah]

the same troubles, honestly when i run the macro the activate in sheet 1 there is no solution except on thing i attach my file but i no know how in this forum or outside link what you suggest

 

[DanteAmor]

Here another macro for you to consider. You can run the macro on any sheet.

Sub transfer_data()
  Dim f As Range, a As Range, sh1 As Worksheet
  Set sh1 = Sheets("Sheet1")
  With Sheets("Sheet2")
    .Range("A5:E" & Rows.Count).ClearContents
    .Range("A5:E5").Value = sh1.Range("A4:E4").Value
    Set f = sh1.Range("F:F").Find(.Range("E3"), , xlValues, xlWhole)
    If Not f Is Nothing Then
      Set a = sh1.Range("A" & f.Row + 3 & ":K" & sh1.Range("A" & f.Row + 3).End(4).Row)
      .Range("A6").Resize(a.Rows.Count, 5).Value = a.Value
      .Range("A" & Rows.Count).End(3)(2).Resize(a.Rows.Count, 5).Value = a.Offset(, 6).Value
    End If
  End With
End Sub