Copy and Paste certain column data to new sheet.

[blackgolf]

Hi guys, please help me with VBA code. I have a data sheet. I have a Result sheet. In Cell A1 of the result sheet I have a date (month and day only). I want to look up this date in the data sheet column K. Whenever the same date (month and day only) is found in Column K, starting from row 6 to last row, it must copy the value of Column B, C and F to Result sheet, column B,C and D starting from row 6. Then next find until last row of data sheet. So every time that the date in cell A1 of Result sheet is found in column K of Data sheet, it must copy the values of Column B, C and F and paste it in Column B, C and D of Result sheet starting at Row 6, or if there are previous data, starting from first empty row of Column B. So if cell B6 is empty it must start pasting it in B6. But if rows 6, 7, 8, 9 and 10 already has data from previous search, then the paste must start at B11, the first empty row. Much appreciated, thanks Chris

 

[jdellasala]

Please post a sample table using XL2BB.

 

[blackgolf]

Hi guys, please help me with VBA code. I have a data sheet. I have a Result sheet. In Cell A1 of the result sheet I have a date (month and day only). I want to look up this date in the data sheet column K. Whenever the same date (month and day only) is found in Column K, starting from row 6 to last row, it must copy the value of Column B, C and F to Result sheet, column B,C and D starting from row 6. Then next find until last row of data sheet. So every time that the date in cell A1 of Result sheet is found in column K of Data sheet, it must copy the values of Column B, C and F and paste it in Column B, C and D of Result sheet starting at Row 6, or if there are previous data, starting from first empty row of Column B. So if cell B6 is empty it must start pasting it in B6. But if rows 6, 7, 8, 9 and 10 already has data from previous search, then the paste must start at B11, the first empty row. Much appreciated, thanks Chris

Book1
	B	C	D	E	F	G	H	I	J	K
5	Name	Surname			Tel					DOB
6	John	Fox			215924244					17 March
7	Fred	Barber			215928795					18 March
8	Allan	Pringle			215872145					19 March
9	Peter	Pax			215589754					17 March
10	Ingrid	Green			215879654					18 March
11	Julia	Robert			216984587					19 March
12	Allen	Green			215986214					19 March
Data Sheet

Book1
	A	B	C	D	E	F	G
1	17 March
2
3
4
5		Name	Surname	Tel No			So the VBA Code must take date in cell A1 (17 March) find it in column K of Data Sheet.
6							Every one that is found , the value of Col B C anf F must be copied and paste in Col BCD in here.
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Result Sheet

 

[jdellasala]

This is the table I started with. It's unclear why there are so many empty columns (or why it starts at B5 for that matter!) so I left them out:

Book1
	G	H	I	J
1	Name	Surname	Tel	DOB
2	John	Fox	215924244	03/17/2022
3	Fred	Barber	215928795	03/18/2022
4	Allan	Pringle	215872145	03/19/2022
5	Peter	Pax	215589754	03/17/2022
6	Ingrid	Green	215879654	03/18/2022
7	Julia	Robert	216984587	03/19/2022
8	Allen	Green	215986214	03/19/2022
Sheet1

The date desired is in cell A1 which is the named range TargetDate. It is a real date with a year, but in this case the year doesn't matter.
The date is pulled into Power Query and the Month and Day determined:

let
    Source = Excel.CurrentWorkbook(){[Name="TargetDate"]}[Content],
    ChangedType = Table.TransformColumnTypes(Source,{{"Column1", type date}}),
    InsertedMonth = Table.AddColumn(ChangedType, "Month", each Date.Month([Column1]), Int64.Type),
    InsertedDay = Table.AddColumn(InsertedMonth, "Day", each Date.Day([Column1]), Int64.Type)
in
    InsertedDay

And the Table named tblData is pulled into Power Query and filtered as needed:

let
    Source = Excel.CurrentWorkbook(){[Name="tblData"]}[Content],
    ChangedType0 = Table.TransformColumnTypes(Source,{{"Name", type text}, {"Surname", type text}, {"Tel", Int64.Type}, {"DOB", type date}}),
    AddedFilteredDOB = Table.AddColumn(ChangedType0, "DOB Keep", each if Date.Month([DOB]) = TargetDate[Month]{0} and Date.Day([DOB]) = TargetDate[Day]{0} then "KEEP" else null),
    FilteredNullRows = Table.SelectRows(AddedFilteredDOB, each ([DOB Keep] = "KEEP")),
    RemovedFilterColumn = Table.RemoveColumns(FilteredNullRows,{"DOB Keep"})
in
    RemovedFilterColumn

Which resulted in this table:

Book1
	B	C	D	E
5	Name	Surname	Tel	DOB
6	John	Fox	215924244	03/17/2022
7	Peter	Pax	215589754	03/17/2022
Sheet1

If you change the date in A1 and then right click on the Report table, it will update to report the date selected:

Book1
	A	B	C	D	E
1	18-Mar
2
3
4
5		Name	Surname	Tel	DOB
6		Fred	Barber	215928795	03/18/2022
7		Ingrid	Green	215879654	03/18/2022
Sheet1

If you want to keep the data for a single report, just copy the entire table and Paste Values (just Paste will not only copy it as a table, but also make a copy of the query, and that won't be useful as a refresh will refresh to the new value in A1!

 

[Fluff]

What version of Excel are you using?

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[mmhill]

See the code below. I made one assumption - the worksheet with the data can be used as a data table. I think that's safe.

In the top of the MAIN CODE below, you will see data that you need to customize for your workbook ... worksheet names, data column headers, etc. Copy the MAIN CODE, paste into a VBA module and make the edits. Then, in the VBA editor, click on the worksheet where you will enter the date and paste the WORKSHEET CODE there.

Whenever you change the date, the code will run and paste in the Name, Surname and phone number of everyone with that Month and Day of birth.

WORKSHEET CODE

Dim booRunChangeEvent As Boolean, booRunning As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    If booRunning Then Exit Sub
    If booRunChangeEvent Then booRunning = True: Call FilterMagic2
    booRunning = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    booRunChangeEvent = Not Application.Intersect(ActiveCell, Range(cReadDateCellAddress)) Is Nothing
End Sub

MAIN CODE

Option Explicit

'edit these to fit your actual spreadsheet
'===============================================================================
Const cDataSheetName$ = "My Data"           'Name of Data worksheet
Const cName$ = "Name"                       'Data Column Header
Const cSurname$ = "Surname"                 'Data Column Header
Const cTel$ = "Tel"                         'Data Column Header

Const cResultSheetName$ = "My Results"      'Worksheet to paste resuts to
Public Const cReadDateCellAddress$ = "A1"   'Cell where date will be
Const cPasteAnchorAddress$ = "B6"           'Cell to start looking to paste data
'===============================================================================

Public Sub FilterMagic2()
Dim oWb As Workbook, iMonth%, iDay%
Dim dbConn As Object, strConn$  'http://www.connectionstrings.com
Dim strSQL$, dbRs As Object, rngOutputAnchor As Range
    
    Set oWb = ThisWorkbook '<< I ASSUME THIS WORKBOOK
    With oWb.Worksheets(cResultSheetName).Range(cReadDateCellAddress)
        iMonth = Month(.Value)
        iDay = Day(.Value)
    End With

    'Make this workbook a database
    Set dbConn = CreateObject("ADODB.Connection"): Set dbRs = CreateObject("ADODB.Recordset")
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"
    dbConn.Open strConn

    'Base SQL string
    strSQL = "SELECT \Name\, \Surname\, \Tel\ FROM [\SheetName\$] WHERE MONTH(DOB)=\MONTH\ and DAY(DOB)=\DAY\;"
        strSQL = Replace(strSQL, "\Name\", cName, vbTextCompare)
        strSQL = Replace(strSQL, "\Surname\", cSurname, vbTextCompare)
        strSQL = Replace(strSQL, "\Tel\", cTel, vbTextCompare)
        strSQL = Replace(strSQL, "\SheetName\", cDataSheetName, vbTextCompare)
        strSQL = Replace(strSQL, "\MONTH\", iMonth, vbTextCompare)
        strSQL = Replace(strSQL, "\DAY\", iDay, vbTextCompare)

    'open record set
    dbRs.Open strSQL, strConn
    'oWb.Names(strTmpName).Delete
    
    'find open cell to push recordset to worksheet
    Set rngOutputAnchor = oWb.Worksheets(cResultSheetName).Range(cPasteAnchorAddress)
    Do While Len(rngOutputAnchor.Value) <> 0
        Set rngOutputAnchor = rngOutputAnchor.Offset(1)
    Loop
    rngOutputAnchor.CopyFromRecordset dbRs
    
CleanUp:

    dbRs.Close: Set dbRs = Nothing
    dbConn.Close: Set dbConn = Nothing
    Set rngOutputAnchor = Nothing
    Set oWb = Nothing
    
Exit Sub
    'OTHER SQL CONSTRUCTIONS
    'https://www.devhut.net/advanced-sql-to-connect-with-excel-workbooks/
    'strSQL = "SELECT * FROM DataTable where YEAR in (1927, 2000, 1885)" ''Named range
    'strSQL = "SELECT * FROM [Filter$A1:A100]" 'Range
    'strSQL = "SELECT * FROM [Sheet1$]" ''All the data in a sheet
    'strSQL = "SELECT * FROM [Excel 12.0 XML;HDR=YES;IMEX=1;database=C:\Docs\LTD.xlsx].[SHEETNAME$XX:XX]" ''Refer to second workbook
End Sub

 

[blackgolf]

Thank you guys, going to start working on it now, will advice the outcome when done.

 

[blackgolf]

Thank you mmhill for your code which I amended to contain my worksheet names etc. The code is running fine (F8) until it must open record set. Then i get the message below. That is at line dbRs.Open strSQL, strConn
Will you please tell me what I must look out for that I missed in No Value given?

Also thanks to jdellasala for power query code. As I know nothing about Power Queries I will first have to study the concept.

​

 

[blackgolf]

Hi #mmhill, can you help me with the error I am getting please!

 

[blackgolf]

Still getting same error, anyone?