Help with code creation
 

I am trying to create vb code to search column 'M' of sheet 'ProCode' and
find all the rows that match the value of Me.CbxDept.text. With this data I
would then like to programactilly like to copy the data cell by cell and row
by row to the sheet that another code has created. The reason for copying
cell by cell is due to the sheet being copied to is formatted with merged
cells. This is what I have already.

Private Sub BtnGo_Click()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T 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 befo=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


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

Help with code creation
 

On 24 Dec., 22:49, Mekinnik
wrote:
I am trying to create vb code to search column 'M' of sheet 'ProCode' and
find all the rows that match the value of Me.CbxDept.text. With this data I
would then like to programactilly like to copy the data cell by cell and row
by row to the sheet that another code has created. The reason for copying
cell by cell is due to the sheet being copied to is formatted with merged
cells. This is what I have already.

Private Sub BtnGo_Click()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T 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 befo=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

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

Try this

Private Sub BtnGo_Click()
Dim tRow()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T 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 befo=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("M1").EntireColumn.Select
Selection.Find(What:=T, After:=ActiveCell, LookIn:=xlFormulas, LookAt
_
:=xlWhole, 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("A2") ' 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

Regards

Per

Help with code creation
 

Jessen,
I managed to get the code you wrote for me to work with very little
modification, however it only finds the first instance of 'T' and not the
rest. If column 'M' have 20 rows of data and 5 of them begin with 'T' then it
should copy all the rows, however it only copies the first 'T' however many
times 'T' shows up. So if the first 'T' is A01,A02,B01,A03,D01,B02,A04......
It should copy all the rows that begin with the letter A, which it does not
it will only copy the first one and copy it to however mant there are and in
this case would be 4 rows of just A01.
"Per Jessen" wrote:

On 24 Dec., 22:49, Mekinnik
wrote:
I am trying to create vb code to search column 'M' of sheet 'ProCode' and
find all the rows that match the value of Me.CbxDept.text. With this data I
would then like to programactilly like to copy the data cell by cell and row
by row to the sheet that another code has created. The reason for copying
cell by cell is due to the sheet being copied to is formatted with merged
cells. This is what I have already.

Private Sub BtnGo_Click()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T 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 befo=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

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

Try this

Private Sub BtnGo_Click()
Dim tRow()
Dim WSNew As Worksheet
'Dim rng As Range
Dim T 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 befo=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("M1").EntireColumn.Select
Selection.Find(What:=T, After:=ActiveCell, LookIn:=xlFormulas, LookAt
_
:=xlWhole, 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("A2") ' 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

Regards

Per