Macro to grap certain cells and copy.....

[Mekinnik]

I am trying to grap the data from my search cell by cell and tell it where to
be copied to on a new worksheet. I have managed to get the data copied to the
new sheet but it is not where I want it to be. Here is the code I have
already gotten from here and modified it to try and accomplish what it is
that I want. I do believe one of my problems is that the columns between the
datasheet and the new sheet do not match. The data sheet has only 13 columns
of data and the new sheet has 18 columns, part is due to 2 of the columns are
going to get there data from another data sheet, but that is another problem
for another day. Thank you all for any help with this dilema.

Private Sub BtnGo_Click()
Dim tRow()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T As String
Dim TS As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'creates a new sheet from the master sheet
T = Me.CbxDept.Text
Sheets("MASTER").Copy before:=Sheets(2)
Set WSNew = ActiveSheet
'creates the name of 'WSNew'
WSNew.Name = T
'assigns cell 'J2' equal to 'T'
WSNew.Cells(2, 10) = T
'copies all data that matches 'T' to new sheet

c = 1
Sheets("ProCode").Select
Range("M2").EntireColumn.Select

Selection.Find(What:=T, after:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True).Activate

ReDim Preserve tRow(c)
tRow(c) = ActiveCell.Row
Do
c = c + 1
Selection.FindNext(after:=ActiveCell).Activate
ReDim Preserve tRow(c)
tRow(c) = ActiveCell.Row
Loop Until tRow(1) = tRow(c)

'Copy cells in column A:M to WSNew
Set tCell = WSNew.Range("A5") ' First destination cell
For R = 1 To c - 1
For Col = 1 To 13
Cells(tRow(c), Col).Copy Destination:=tCell

Set tCell = tCell.Offset(0, 1)
Next
Set tCell = tCell.Offset(1, -(Col - 1)) ' Next row
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Joel]

I don't think you were incrementing the destination row. This code is
simplier and easier to follow

Private Sub BtnGo_Click()
Dim tRow()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T As String
Dim TS As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'creates a new sheet from the master sheet
T = Me.CbxDept.Text
Sheets("MASTER").Copy before:=Sheets(2)
Set WSNew = ActiveSheet
'creates the name of 'WSNew'
WSNew.Name = T
'assigns cell 'J2' equal to 'T'
WSNew.Range("J2") = T
'copies all data that matches 'T' to new sheet

NewRow = 5
With Sheets("ProCode")

Lastrow = .Range("M" & Rows.Count).End(xlUp).Row
For RowCount = 2 To Lastrow
If .Range("M" & RowCount) = T Then

'Copy cells in column A:M to WSNew
Set CopyRange = .Range("A" & RowCount & ":M" & _
RowCount)
CopyRange.Copy _
Destination:=WSNew.Range("A" & NewRow)
NewRow = NewRow + 1
End If
Next RowCount
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Mekinnik]

Joel,
I am sorry for not getting back to you sooner on my last post you replied
to, work got to busy, so I had to put this aside. I will try your code and
get back to you later today with a reply, and thank you for all your help.

 

[Mekinnik]

Joel,
I tried the code you posted, however it doesn't do anything but create a
new sheet it does not copy any of the data matching 'T' at all it just make a
blank sheet. I did verify that I did have data on sheet 'ProCode' to copy but
it doesn't copy it over, any suggestion?

 

[Mekinnik]

Joel,
I stepped through the code and found that it is bypassing the copying part
of the code and going right to the end if. I do believe it has to do with the
fact that column 'M' hold an alphanumeric string that I have created, where
the first 2 characters are letters and the other 3 are numbers, so I think
the search code has to be told to find 'T' within the left 2 characters of of
the cells in column 'M', only I have not figured out how to do it yet.