copy some columns based on the value in column "A".

H

harzer

Board Regular
Joined
Dec 15, 2021
Messages
159
Office Version
  1. 2016
Platform
  1. Windows
Hello everyone,
The source sheet is: "Parents".
The Destination sheet is: “ElevéPar”.
In my "Parents" sheet, I have a large database, this database has 11 columns in total, columns ("A:K"), I want to copy some specified columns, in my case it is of the following columns: ("A", "B","C", "F", "G", "H", "J", "K") of the "Parents" sheet.
The copy will be made on the only condition: if the value of the last 5 characters of the cells of column "A" are equal to: "2024 M" or "2024 F", knowing that "2024" corresponds to the current year followed by either the letter “M” or “F”
Thank you for your contributions.

Here is a small example of data for testing:

Elevage.xlsm
ABCDEFGHIJK
1JeunePèreMèreEleveurAgeVolièreCageNé(e)ToursCouleurElevage
2Ae27-054/2023 MAe27-010/2021 MMn96-034/2021 FLamback Léon0a 11m 3j5H502-07-20234TMâle
3Ae27-055/2023 FMn96-046/2019 MMn96-010/2021 FLamback Léon0a 10m 25j4B912-07-20234TFemelleX
4Ae27-056/2023 FMn96-046/2019 MMn96-010/2021 FLamback Léon0a 10m 25j4B912-07-20234TFemelle
5Ae27-057/2023 FMn96-046/2019 MMn96-010/2021 FLamback Léon0a 10m 25j4B912-07-20234TFemelle
6Ae27-058/2023 FMn96-046/2019 MMn96-010/2021 FLamback Léon0a 10m 25j4B912-07-20234TFemelle
72024-059/2023 MMn96-046/2019 MMn96-010/2021 FLamback Léon0a 10m 25j5H912-07-20234TMâle
830247-060/2023 M3024-066/2020 M2207-032/2020 FLamback Léon1a 0m 13j5B3024-05-20234TMâleX
9Ae27-060/2023 FAe27-010/2021 MAe27-038/2022 FLamback Léon0a 10m 20j4B317-07-20234TFemelle
10Ae27-061/2023 FAe27-010/2021 MAe27-038/2022 FLamback Léon0a 10m 20j4B317-07-20234TFemelle
11Ae27-062/2023 FAe27-010/2021 MAe27-038/2022 FLamback Léon0a 10m 20j4B317-07-20234TFemelle
12Ae27-063/2023 FAe27-010/2021 MAe27-038/2022 FLamback Léon0a 10m 20j4B317-07-20234TFemelle
13Ae27-064/2023 FAe27-010/2021 MAe27-038/2022 FLamback Léon0a 10m 20j4B317-07-20234TFemelle
14Ae27-065/2023 FAe27-021/2022 MAe27-020/2022 FLamback Léon0a 10m 20j4B817-07-20234TFemelle
15Ae27-066/2023 MAe27-018/2022 MMn96-045/2022 FLamback Léon0a 10m 23j5H1014-07-20234TMâle
16Ae27-067/2023 MAe27-018/2022 MMn96-045/2022 FLamback Léon0a 10m 23j5H1014-07-20234TMâle
17Ae27-068/2023 FAe27-018/2022 MMn96-045/2022 FLamback Léon0a 10m 23j4B1014-07-20234TFemelle
18Ae27-069/2023 MAe27-018/2022 MMn96-045/2022 FLamback Léon0a 10m 23j5H1014-07-20234TMâle X
19Ae27-070/2023 MAe27-022/2022 MAe27-031/2022 FLamback Léon0a 10m 20j5H617-07-20234TMâle
20Ae27-071/2023 FAe27-022/2022 MAe27-031/2022 FLamback Léon0a 10m 20j4B617-07-20234TFemelle
21Ae27-072/2023 MAe27-033/2022 MMn96-008/2022 FLamback Léon0a 10m 19j5H1118-07-20234TMâle
22Ae27-073/2023 MAe27-033/2022 MMn96-008/2022 FLamback Léon0a 10m 19j5H1118-07-20234TMâle
23Ae27-074/2023 FAe27-033/2022 MMn96-008/2022 FLamback Léon0a 10m 19j4B1118-07-20234TFemelle
24Ae27-001/2024 FAe27-010/2021 MAe27-017/2023 FLamback Léon0a 1m 13j5H1224-04-20244TFemelle Tte jauneElevé / Ae27-017/23
25Ae27-002/2024 MAe27-010/2021 MAe27-017/2023 FLamback Léon0a 1m 13j5H1224-04-20244TMâle Tt jauneElevé / Ae27-017/23
26Ae27-003/2024 FAe27-036/2023 MMn96-045/2022 FLamback Léon0a 1m 9j5H1328-04-20244TFemelle Tte jauneElevé / Ae27-017/23
27Ae27-004/2024 FAe27-036/2023 MMn96-045/2022 FLamback Léon0a 1m 9j5H1328-04-20244TFemelle Tâche aile droiteElevé / Ae27-017/23
28Ae27-005/2024 MAe27-022/2023 MAe27-015/2023 FLamback Léon0a 1m 4j5H1101-05-20244TMâle Tte jauneElevé / Ae27-023/23
29Ae27-006/2024 MAe27-022/2023 MAe27-015/2023 FLamback Léon0a 1m 4j5H1101-05-20244TMâle Tâche derrière œil gaucheElevé / Ae27-023/23
30Ae27-007/2024 M5919-001/2023 MAe27-023/2023 FLamback Léon0a 1m 4j5H801-05-20244TMâle Tt jauneElevé / Ae27-023/23
31Ae27-008/2024 MAe27-033/2022 MAe27-009/2023 FLamback Léon0a 1m 4j5H401-05-20244TMâle Tâche au dosElevé / Ae27-023/23
32Ae27-009/2024 MAe27-033/2022 MAe27-009/2023 FLamback Léon0a 1m 4j5H401-05-20244TMâle Tâche au dosElevé / Mn96-045/22
33Ae27-010/2024 MAe27-033/2022 MAe27-009/2023 FLamback Léon0a 1m 4j5H401-05-20244TMâle Tâche ronde à la têteElevé / Mn96-045/22
34Ae27-011/2024 MAe27-035/2022 MAe27-055/2023 FLamback Léon0a 1m 2j5H1603-05-20244TMâle
35Ae27-012/2024 MAe27-035/2022 MAe27-055/2023 FLamback Léon0a 1m 2j5H1603-05-20244TMâle
36Ae27-013/2024 MAe27-035/2022 MAe27-055/2023 FLamback Léon0a 1m 2j5H1603-05-20244TMâle
37Ae27-014/2024 MAe27-035/2022 MAe27-055/2023 FLamback Léon0a 1m 2j5H1603-05-20244TMâle
38Ae27-015/2024 MAe27-035/2022 MAe27-055/2023 FLamback Léon0a 1m 2j5H1603-05-20244TMâle
39Ae27-016/2024 MMn96-020/2023 MAe27-038/2022 FLamback Léon0a 0m 31j5H1006-05-20244TMâle
40Ae27-017/2024 MMn96-020/2023 MAe27-038/2022 FLamback Léon0a 0m 31j5H1006-05-20244TMâle
41Ae27-018/2024 MAe27-069/2023 MMn96-034/2021 FLamback Léon0a 0m 31j5H206-05-20244TMâle Elevé / Ae27-026/22
42Ae27-019/2024 MAe27-022/2022 MMn96-010/2021 FLamback Léon0a 0m 30j5H907-05-20244TMâle
43Ae27-020/2024 MAe27-022/2022 MMn96-010/2021 FLamback Léon0a 0m 30j5H907-05-20244TMâle
44Ae27-021/2024 MAe27-022/2022 MMn96-010/2021 FLamback Léon0a 0m 30j5H907-05-20244TMâle
Parents
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Try:
VBA Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, lRow As Long
    Set srcWS = Sheets("Parents")
    Set desWS = Sheets("ElevéPar")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1").CurrentRegion.AutoFilter 1, Criteria1:="=*" & Year(Date) & "*"
        Intersect(.Rows("1:" & lRow), .Range("A:C, F:H, J:K").SpecialCells(xlVisible)).Copy desWS.Range("A1")
        desWS.Columns.AutoFit
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try on a copy.
VBA Code: 
Sub CopyFilteredData()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim sourceData As Variant
    Dim destData() As Variant
    Dim i As Long, j As Long
    Dim destRow As Long

    Set wsSource = ThisWorkbook.Sheets("Parents")
    Set wsDest = ThisWorkbook.Sheets("ElevéPar")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    sourceData = wsSource.Range("A1:K" & lastRow).Value
    
    ReDim destData(1 To lastRow, 1 To 8)
    destRow = 1
    For i = 2 To UBound(sourceData, 1)
        If Right(sourceData(i, 1), 6) = "2024 M" Or Right(sourceData(i, 1), 6) = "2024 F" Then
            destData(destRow, 1) = sourceData(i, 1) ' Column A
            destData(destRow, 2) = sourceData(i, 2) ' Column B
            destData(destRow, 3) = sourceData(i, 3) ' Column C
            destData(destRow, 4) = sourceData(i, 6) ' Column F
            destData(destRow, 5) = sourceData(i, 7) ' Column G
            destData(destRow, 6) = sourceData(i, 8) ' Column H
            destData(destRow, 7) = sourceData(i, 10) ' Column J
            destData(destRow, 8) = sourceData(i, 11) ' Column K
            destRow = destRow + 1
        End If
    Next i

    If destRow > 1 Then
        wsDest.Range("A2").Resize(UBound(destData, 1), 8).Value = destData
    End If

End Sub
 
Upvote 0
Hello mumps
Thanks for your feedback.
The code that you suggest to me works almost well, it does not give me the real desired result, namely it should not copy line number 7 of the database, because the cell in column "A" (of this line ) ends with "2023 M", but I only want to copy cells ending with "2024 M" or "2024 F".
I await your reply.
Thanks
 
Upvote 0
Try:
VBA Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, lRow As Long
    Set srcWS = Sheets("Parents")
    Set desWS = Sheets("ElevéPar")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1").CurrentRegion.AutoFilter 1, Criteria1:="=*" & Year(Date) & " M", Operator:=xlOr, Criteria2:="=*" & Year(Date) & " F"
        Intersect(.Rows("1:" & lRow), .Range("A:C, F:H, J:K").SpecialCells(xlVisible)).Copy desWS.Range("A1")
        desWS.Columns.AutoFit
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hello mumps, Cubist and the forum,
I start with Cubist to tell him that his code works very well, thank you.
However, I would like to ask you for a small update to finalize the code, namely, can you (Please) write a code that adds the headers to the first line of the "ElevéPar" destination sheet.
Thanking you in advance.
If I ask you for this update it is to have two macros that are functional, yours and that of mumps.
Now I reply to mumps to tell him that the proposed update satisfies me and gives me the desired result.
Thanks a lot to both of you.
 
Upvote 0
harzer said:
However, I would like to ask you for a small update to finalize the code, namely, can you (Please) write a code that adds the headers to the first line of the "ElevéPar" destination sheet.
Click to expand...
VBA Code: 
Sub CopyFilteredDataUsingArray()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim sourceData As Variant
    Dim destData() As Variant
    Dim i As Long, j As Long
    Dim destRow As Long

    Set wsSource = ThisWorkbook.Sheets("Parents")
    Set wsDest = ThisWorkbook.Sheets("ElevéPar")

    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row

    sourceData = wsSource.Range("A1:K" & lastRow).Value

    ReDim destData(1 To lastRow, 1 To 8)

    destRow = 1

    For i = 1 To UBound(sourceData, 1)
        If i = 1 Or Right(sourceData(i, 1), 6) = "2024 M" Or Right(sourceData(i, 1), 6) = "2024 F" Then
            destData(destRow, 1) = sourceData(i, 1) ' Column A
            destData(destRow, 2) = sourceData(i, 2) ' Column B
            destData(destRow, 3) = sourceData(i, 3) ' Column C
            destData(destRow, 4) = sourceData(i, 6) ' Column F
            destData(destRow, 5) = sourceData(i, 7) ' Column G
            destData(destRow, 6) = sourceData(i, 8) ' Column H
            destData(destRow, 7) = sourceData(i, 10) ' Column J
            destData(destRow, 8) = sourceData(i, 11) ' Column K

            destRow = destRow + 1
        End If
    Next i

    If destRow > 1 Then
        wsDest.Range("A1").Resize(UBound(destData, 1), 8).Value = destData
    End If

End Sub
 
Last edited:
Upvote 0
Hello Cubist and the forum,
Thanks for the feedback and update.
The proposed code works well and satisfies me perfectly, Big THANKS to you Cubist.
Greetings.
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Copy rows if cells in column "K" end with either "X" or "x".
Replies
3
Views
235
rollis13
rollis13
H
  • Solved
Capitalize the last character in column “K” conditionally.
Replies
3
Views
233
Fluff
Fluff
H
  • Solved
Delete the last character of cells in column "K" if it is equal to "X" or "x"
Replies
8
Views
162
Fuji
F
H
  • Solved
Retrieve the intersection of multiple cells with respect to columns and rows
2
Replies
10
Views
165
mumps
mumps
H
  • Solved
Search for topics based on their groups.
Replies
7
Views
406
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,828
Messages
6,181,214
Members
453,024
Latest member
Wingit77

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top