Maintaining column formatting when copying a row to another sheet based on a value

[Roger Tapp]

I found some code that does what I need it to do but I need some
modification to it. It checks column "G" for a value and based on that
value copies the row to a seperate sheet. I would like to put in a
Select Case to write out sheet names based on that value instead of
just the "value" for the sheet name. I also need it to maintain the
column widths when it copies from the master list to the new sheets.
Currently they are collapsed to a uniform size. And last I would like
it to clear all of the sheets EXCEPT the master sheet everytime it
runs to get a fresh write and not duplicate the items on the sheet.
Here is the current code I am using:

Option Explicit
Sub CopyRowsToSheets()
'copy rows to worksheets based on value in column A
'assume the worksheet name to paste to is the value in Col A
Dim CurrentCell As Range
Dim SourceRow As Range
Dim Targetsht As Worksheet
Dim Testwksht As String
Dim TargetRow As Long
Dim CurrentCellValue As String


'start with cell A3 on Sheet1
Set CurrentCell = Worksheets("MIPR Master Item List").Cells(3, 6)
'row 3 column 6

Do While Not IsEmpty(CurrentCell)
CurrentCellValue = CurrentCell.Value & CurrentCell.ColumnWidth
Set SourceRow = CurrentCell.EntireRow


'Check if worksheet exists
On Error Resume Next
Testwksht = Worksheets(CurrentCellValue).Name
If Err.Number = 0 Then
'MsgBox CurrentCellValue & " worksheet Exists"
Else
MsgBox "Adding a new worksheet for " & CurrentCellValue
Worksheets.Add.Name = CurrentCellValue
End If

On Error GoTo 0 'reset on error to trap errors again

Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)
'note: using CurrentCell.value gave me an error if the value was
'numeric

' Find next blank row in Targetsht - check using Column A
TargetRow = Targetsht.Cells(Rows.Count, 1).End(xlUp).Row + 1
SourceRow.Copy Destination:=Targetsht.Cells(TargetRow, 1)

'do the next cell
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop
End Sub



I would certainly appreciate ideas/help. I have dabbled in programming
but that was a few years ago and have forgotten more of it than I
remember.

Thanks for the assist....

Roger Tapp

 

[Tom Ogilvy]

Actually, your code looks at Column F

Cells(3,6) is Cell F3


This looks awful peculiar
CurrentCellValue = CurrentCell.Value & CurrentCell.ColumnWidth

Why do you append the columnwidth to the currentcell.value to get a
sheetname?

I assume you want the code modified to get a value from Column A rather than
column F/G. Do you then want to have some type of table that translates
that value to a sheet name. Say column A has the value 123 and you want
that row to go to a Sheet named BASEOPS. Is this what you mean by a select
case. If so, how big is the list of values/sheetnames?

I assume the terminology "write out the sheet names" means to put the
sheet name in the variable used to determine which sheet to write to.

 

[Roger Tapp]

You are right on all counts. I am checking on a value in column F (I
didn't update the remarks). Based on that I copy the row to a sheet. The
"& CurrentCell.ColumnWidth" code is in fact an error that I didn't clear
out before I copied the code in the message. A table to translate the
codes to a proper sheet name would be good. The Baseops scenario is
correct based upon a code value of say "O". The worksheet names can
probably be kept under 15 characters. The only other aspect you did not
touch on was to clear all but the "MASTER" sheet at each execution of
the procedure. This way no duplication would exist on the sheets.

Sorry about the confusion. Hope this clarifies all aspects of my
original question.

Roger

 

[Tom Ogilvy]

Option Explicit
Sub CopyRowsToSheets()
'copy rows to worksheets based on value in column A
'assume the worksheet name to paste to is the value in Col A
Dim CurrentCell As Range
Dim SourceRow As Range
Dim Targetsht As Worksheet
Dim Testwksht As Worksheet
Dim sh As Worksheet
Dim targ As Variant
Dim TargetRow As Long
Dim CurrentCellValue As String
Dim vCodes As Variant, vNames As Variant
Dim i As Long, res As Variant

' codes much match what is in the sheet (if string, then string, if number
' then number - if you could have "123" or 123, then enter one of each
' and duplicate the Sheetname in the corresponding array vNames or
' clean up your data
vCodes = Array(1, 123, "123", "AA", 33, "F91", "G", "H")
vNames = Array("Sheet1", "Sheet2", "Sheet2", "Sheet3", "Sheet4", _
"Sheet5", "Sheet6", "Sheet7")

' Add any missing sheets
For i = LBound(vNames) To UBound(vNames)
'Check if worksheet exists
CurrentCellValue = vNames(i)
Set Testwksht = Nothing
On Error Resume Next
Set Testwksht = Worksheets(CurrentCellValue)
On Error GoTo 0
If Not Testwksht Is Nothing Then
'MsgBox CurrentCellValue & " worksheet Exists"
Else
MsgBox "Adding a new worksheet for " & CurrentCellValue
Worksheets.Add.Name = CurrentCellValue
End If
Next i

'start with cell A3 on Sheet1
Set CurrentCell = Worksheets("MIPR Master Item List").Cells(3, 1)
'row 3 column 6

' clear sheets and format
For Each sh In Worksheets
If sh.Name <> Worksheets("MIPR Master Item List").Name Then
Worksheets("MIPR Master Item List").Cells.Copy _
Destination:=sh.Cells
sh.Rows("3:65536").Delete
End If
Next

' process the data
Do While Not IsEmpty(CurrentCell)
If IsNumeric(CurrentCell.Value) Then
targ = CDbl(CurrentCell.Value)
Else
targ = Trim(CurrentCell.Value)
End If
res = Application.Match(targ, vCodes, 0)
If IsError(res) Then
MsgBox "code " & CurrentCell.Value & " can not be found, halting"
Exit Sub
End If
CurrentCellValue = vNames(res - 1)
' CurrentCellValue = CurrentCell.Value
Set SourceRow = CurrentCell.EntireRow
Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)

' Find next blank row in Targetsht - check using Column A
TargetRow = Targetsht.Cells(Rows.Count, 1).End(xlUp).Row + 1
SourceRow.Copy Destination:=Targetsht.Cells(TargetRow, 1)

'do the next cell
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop
End Sub

This ran fine for me. Fill in your codes in

vCodes = Array( . . . )
and your corresponding sheetnames in

vNames = Array( . . . )