copy range

[Mauro]

Hello everybody, I have a problem:
In my Sheet1 I have column A, D, G, J, M, P, S and V with values I need to
copy to Sheet2. The values are only the ones that in the second column to
the right have an * (so for A - C and so on).
There is a format I must follow (val=value): CellA headervalOZ/valOZ.T and
so on. I.E. PMC12345OZ/23457OZ.T2 (T=nr of values on that line). The max
amount of values per line is 5. If there are more than 5 value in a column
then a new alinea must be started. If there are less values then the values
in the new line must begin in a new row. I am not sure that what I wrote
makes any sense to you... but I surely hope so (it is all oh so clear in my
mind... lol)

thanks in advance for any help

 

[joel]

Your instruction are a little vague. I took some guesses what yo
wanted. Try this code. I can make somje simple changes if it is no
exactly correct



VBA Code:
--------------------


Sub MoveData()

NewRow = 1

With Sheets("Sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
NewCol = 2
AsteriskCount = 0
Header = .Range("A" & RowCount)
For ColIndex = 0 To 7
ColNumber = 3 * (ColIndex + 1)
Asterisk = .Cells(RowCount, ColIndex).Offset(0, 2)
Data = .Cells(RowCount, ColIndex).Offset(0, 2)
With Sheets("sheet2")
If Asterisk = "*" Then
AsteriskCount = AsteriskCount + 1
If AsteriskCount = 6 Then
NewCol = 2
AsteriskCount = 0
'total amounts on the line
Set SumRange = .Range("B" & NewRow & ":F" & NewRow)
Total = WorksheetFunction.Sum(SumRange)
.Range("A" & NewRow) = Header & "OZ/" & Total & "OZ.5"
NewRow = NewRow + 1
End If
.Cells(NewRow, NewCol) = Data
NewCol = NewCol + 1
End If
End With
Next ColIndex
If AsteriskCount > 0 Then
Set SumRange = .Range("B" & NewRow & ":F" & NewRow)
Total = WorksheetFunction.Sum(SumRange)
.Range("A" & NewRow) = Header & "OZ/" & Total & "OZ." & _
AsteriskCount
NewRow = NewRow + 1
End If
Next RowCount
End With


End Sub

--------------------

 

[Don Guillett]

I sent OP file using this.

Sub SAS_DoTelexSheet()
Application.ScreenUpdating = False
Sheets("telex").Columns(1).ClearContents
SAS_SortSCM_AllColumns'called to sort
With Sheets("SCM")
On Error Resume Next 'if no entries
For i = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 3
clr = .Cells(.Rows.Count, i + 2).End(xlUp).Row
'MsgBox clr
r = 2
dlr = Sheets("Telex").Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To Int(clr / 5) + 1 'MsgBox j
ms = ""
'MsgBox j
tc = 0
For k = 0 To 4
If .Cells(r + k, i + 2) = "*" Then
ms = ms & .Cells(r + k + 0, i) & "OZ/"
tc = tc + 1
End If
Next k
r = r + 5
'MsgBox tc
'MsgBox "." & Cells(1, i) & " " & Left(ms, Len(ms) - 1)
Sheets("Telex").Cells(dlr, 1) = "." & .Cells(1, i) & " " & Left(ms,
Len(ms) - 1) & ".T" & tc
Sheets("Telex").Cells(1, 1) = "Telex"
dlr = dlr + 1
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub