VBA, search in range of data and then copy and paste

[dinokovac93]

Hi Guys,

I'm working on a extremely tedious project and my hands are about to fall off .

So to give you an idea of what I'm doing, check out this GIF:

(Note: In the GIF: there are more columns to fill out)

So I'm not sure if there is a VBA possible for filling out all of the information.

What the Macro would need to do is (or at least what I think it needs):

1. Search (loop) through the ranges of data in sheet 5.

2. It will copy and paste all the dates from sheet 5 (which are always in column A) into sheet 6 dates column.

3. Now sheet 6 has the dates filled out, along with the column names. This is the key information to taking data from sheet 5 and putting it in sheet 6.

4. There are more columns in sheet 5 but we only need the columns that are in sheet 6.

5. The columns's names in sheet 6 match the same columns in sheet 5.

6. To wrap it up: the macro will use the dates and column names from sheet 6 to obtain the data from sheet 5.


If anyone get help or have any suggestions please let me know, its really appreciated.


[TABLE="width: 4299"]
<tbody>[TR]
[TD]Subject ID[/TD]
[TD]name[/TD]
[TD]visit_date[/TD]
[TD]intraocular pressure - right[/TD]
[TD]intraocular pressure - left[/TD]
[TD]VA - Right Distance SC[/TD]
[TD]VA - Right Distance SC +-[/TD]
[TD]VA - Right Distance CC[/TD]
[TD]VA - Right Distance CC +-[/TD]
[TD]VA - Right Distance PH SC[/TD]
[TD]VA - Right Distance PH CC[/TD]
[TD]VA - Left Distance SC[/TD]
[TD]VA - Left Distance SC +-[/TD]
[TD]VA - Left Distance CC[/TD]
[TD]VA - Left Distance CC +-[/TD]
[TD]VA - Left Distance PH SC[/TD]
[TD]VA - Left Distance PH CC[/TD]
[TD]VA Type[/TD]
[TD]Wearing Rx - Right Sphere[/TD]
[TD]Wearing Rx - Right Cylinder[/TD]
[TD]Wearing Rx - Right Axis[/TD]
[TD]Wearing Rx - Right Add[/TD]
[TD]Wearing Rx - Left Sphere[/TD]
[TD]Wearing Rx - Left Cylinder[/TD]
[TD]Wearing Rx - Left Axis[/TD]
[TD]Wearing Rx - Left Add[/TD]
[TD]Wearing Rx - Current Age[/TD]
[TD]Manifest Refraction - Right Sphere[/TD]
[TD]Manifest Refraction - Right Cylinder[/TD]
[TD]Manifest Refraction - Right Axis[/TD]
[TD]Manifest Refraction - Right Add[/TD]
[TD]Manifest Refraction - Right Dist VA[/TD]
[TD]Manifest Refraction - Right Near VA[/TD]
[TD]Manifest Refraction - Left Sphere[/TD]
[TD]Manifest Refraction - Left Cylinder[/TD]
[TD]Manifest Refraction - Left Axis[/TD]
[TD]Manifest Refraction - Left Add[/TD]
[TD]Manifest Refraction - Left Dist VA[/TD]
[TD]Refraction Type[/TD]
[TD]Pachymetry - Right Eye[/TD]
[TD]Pachymetry - Left Eye[/TD]
[TD]external exam - right eye[/TD]
[TD]external exam - left eye[/TD]
[TD]Slit Lamp Exam - Right Lids[/TD]
[TD]Slit Lamp Exam - Right Conjunctiva[/TD]
[TD]Slit Lamp Exam - Right Cornea[/TD]
[TD]Slit Lamp Exam - Right AC[/TD]
[TD]Slit Lamp Exam - Right Lens[/TD]
[TD]Slit Lamp Exam - Right Iris[/TD]
[TD]Slit Lamp Exam - Right Vitreous[/TD]
[TD]Slit Lamp Exam - Left Lids[/TD]
[TD]Slit Lamp Exam - Left Conjunctiva[/TD]
[TD]Slit Lamp Exam - Left Cornea[/TD]
[TD]Slit Lamp Exam - Left AC[/TD]
[TD]Slit Lamp Exam - Left Lens[/TD]
[TD]Slit Lamp Exam - Left Iris[/TD]
[TD]Slit Lamp Exam - Left Vitreous[/TD]
[TD]Fundus Exam - Right Disc[/TD]
[TD]Fundus Exam - Right Macula[/TD]
[TD]Fundus Exam - Right Periphery[/TD]
[TD]Fundus Exam - Right Vessels[/TD]
[TD]Fundus Exam - Left Disc[/TD]
[TD]Fundus Exam - Left Macula[/TD]
[TD]Fundus Exam - Left Periphery[/TD]
[TD]Fundus Exam - Left Vessels[/TD]
[TD]Fundus Exam - Right Cup/Disc Ratio[/TD]
[TD]Fundus Exam - Left Cup/Disc Ratio[/TD]
[/TR]
</tbody>[/TABLE]

 

[CalcSux78]

Here's a start...

Option Explicit



Sub dinokovac93()
Dim lrow&, col&
Dim cel As Range
Dim rng As Range


With Sheet5
    lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range(.[A2], .Cells(lrow, 1)).Copy Sheet6.[C2]   'copy dates
End With


With Sheet6
    'set rng with column headers from sheet 6
    Set rng = .Range(.[D1], .Cells(1, .Columns.Count).End(xlToLeft))
    For Each cel In rng.Cells
        If WorksheetFunction.CountIf(Sheet5.Rows(1), cel) > 0 Then
            col = WorksheetFunction.Match(cel.Value, Sheet5.Rows(1), 0)
            Sheet5.Range(Sheet5.Cells(2, col), Sheet5.Cells(lrow, col)).Copy cel.Offset(1)
        End If
    Next cel
End With


End Sub

This sub uses a FOR loop to find matches in the first row of the two sheets. When a match is found, the range is copied to the destination sheet.