PDA

View Full Version : Fairly simple problem



Sam1015
10-01-2009, 09:54 AM
I just started learning VBA and encountered 2 problems I'm sure would only take someone who actually knows what they're doing a minute.

I have two workseets, I am trying to pull information from the first worksheet and paste it into the desired cells on the second. I need to do this by matching the project numbers in each sheet (i)....here's the first problem, I can't figure out how paste the information in the correct cells.

The entire code so far is the following:


Private Sub CommandButton1_Click()


Dim SearchRange As Range
Dim FoundCells As Range
Dim FoundCell As Range
Dim FindWhat As Variant
Dim MatchCase As Boolean
Dim LookIn As XlFindLookIn
Dim LookAt As XlLookAt
Dim SearchOrder As XlSearchOrder
Dim row As Integer
Dim i As Integer
Dim row_index As Integer
Dim col_index As Integer



row = 9
i = 2


Set SearchRange = ThisWorkbook.Worksheets(1).Range("A1:M175")
FindWhat = Cells(row, i).Value
LookIn = xlValues
LookAt = xlPart
SearchOrder = xlByRows
MatchCase = False

Set FoundCells = FindAll(SearchRange:=SearchRange, FindWhat:=FindWhat, _
LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)


If FoundCells Is Nothing Then
Debug.Print "No cells found."

Else
For Each FoundCell In FoundCells.Cells
Debug.Print FoundCell.Address, FoundCell.Text


row_index = FoundCell.row
col_index = FoundCell.Column


ThisWorkbook.Worksheets(2).Cells(row, i + 3).Value = ThisWorkbook.Worksheets(1).Cells(row_index, col_index + 2).Value

ThisWorkbook.Worksheets(2).Cells(row, i + 5).Value = ThisWorkbook.Worksheets(1).Cells(row_index, col_index + 3).Value

ThisWorkbook.Worksheets(2).Cells(row, i + 7).Value = ThisWorkbook.Worksheets(1).Cells(row_index, col_index + 4).Value

Next FoundCell


End If
End Sub

Function FindAll(SearchRange As Range, FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False) As Range

Dim FoundCell As Range
Dim FoundCells As Range
Dim LastCell As Range
Dim FirstAddr As String
With SearchRange

Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then

Set FoundCells = FoundCell

FirstAddr = FoundCell.Address
Do

Set FoundCells = Application.Union(FoundCells, FoundCell)
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
Loop Until (FoundCell Is Nothing) Or (FoundCell.Address = FirstAddr)
End If

If FoundCells Is Nothing Then
Set FindAll = Nothing
Else
Set FindAll = FoundCells
End If
End Function


My problem 1st problem is I need the information data from sheet 1 to past 3 rows below "i" and then over +3, +5, +7 columns on sheet 2. the code for this action is at the end of the Sub Procedure (highlighted in Green)

The second problem is the above code only does this for one project. I need it to do a loop and repeat this action for all the projects.

I hope my explanation was accurate enough as I literally just starting learning vba last week. Any help would be greatly greatly appreciate.

Thanks!!

Bob Phillips
10-01-2009, 10:19 AM
Can't you just use VLOOKUP formulae?

Sam1015
10-01-2009, 10:34 AM
Unfortunately no, because I'll need to run this every week when new data comes out (worksheet 1) and there are about 500 projects. Since I'm trying to coper over three different cells of information for each project it would take a large amount of time.

Is this a larger problem then I thought?

Thank you for your quick response xld!

Bob Phillips
10-01-2009, 10:37 AM
No, it is just that formulae are so simple. I also don't see 3 cells or 500 projects as a barrier, setup the formulae, and they pick it up automatically.

If it must be VBA, can you post a sample workbook?

Sam1015
10-01-2009, 11:39 AM
Please see attached for an example workbook. The number of projects would be larger then the amount in the attached.

I've highlighted the cells in yellow on worksheet 2 where I'm trying to get them to paste.

MANY THANKS!

mdmackillop
10-01-2009, 02:41 PM
Where is the data that goes into these cells?

Sam1015
10-01-2009, 02:47 PM
The data that would go into the highlighted cells is located on worksheet 1 ("Input"). It would be Columns H, I, J respective to matching up the Project numbers on both sheets.

I don't foresee it going beyond 500 rows/searches.

I greatly appreciate your efforts on this.

mdmackillop
10-01-2009, 03:14 PM
Assuming project numbers are unique on Input

Private Sub CommandButton1_Click()
Dim Source As Worksheet, Tgt As Worksheet
Set Source = Sheets(1)
Set Tgt = Sheets(2)
For i = 9 To Tgt.Cells(Rows.Count, 2).End(xlUp).row Step 7
Set c = Source.Columns(6).Find(Cells(i, 2).Value)
If Not c Is Nothing Then
Tgt.Cells(i + 3, 5) = c.Offset(, 2)
Tgt.Cells(i + 3, 7) = c.Offset(, 3)
Tgt.Cells(i + 3, 9) = c.Offset(, 4)
End If
Next
End Sub

Sam1015
10-01-2009, 03:56 PM
Yes they are, THANK YOU it worked perfectly.

Greatly appreciate your efforts!!!!!!!