copy values from vertically-horizontally

[vasileib7]

I am a learner at VB and I would like to write a macro for the
following problem.
This is an example of a spreadsheet I have with the following column
titles:
A B
C D E F G
H I
1 Product Description
SUF SFM Bin
2 123254 Whisky 10oz
1 67U0311
3 Pty Bin Qty
Stkd Diff
4 1 67U0311 15
5 1 67J1220 13
6 2 67L2329 16
7 Total 34
8 138822 Plate 10cm
1 67K2120
9 Pty Bin Qty
Stkd Diff
10 1 67K2120 3
11 2 67K2128 5
12 2 67K2129 8
13 Total 16

Basically it contains the product code, description, SUF (pack size)
and SFM Bin (bin assigned). Under that 123254 is the product code and
then under that Pty is the priority (takes values from 1 to 2 only)
and next to it the alternative bins and the quantity contained next to
it.

First of all, I need a macro that will get rid of the rows that
contain in column A "Pty" and "Total". I don't need this information.
I have managed to write a macro for this, which works.
Then I need a macro to cut the alternative bin which is in B4 to E2
and the quantity which is C4 to F2. Then again B5 to G2 and C5 to H2
and B6 to I2 and C6 to J2.
Then the same again with the next product code. B10 to E8, C10 to F8,
B11 to G8, C11 to H8, B12 to I8, C12 to J8.

A friend has written the macro for me but it doesn't work quite well.
Sometimes the next product gets mixed with the above product.

What I want to achieve is bring all the information in one line so
that I can sort afterwards to whatever column I want. Therefore, I
should have rows like the following:
123254 Whisky 10oz 1 67U0311 67U0311 15 67J1220 13
67L2329 16
138822 Plate 10cm 1 67K2120 67K2120 3 67K2128
5 67K2129 8

The macro that I have which doesn't work 100% is the following:

Sub ProcessData()

'Remove rows

Dim currentrow As Integer
Dim lastrow As Integer
currentrow = 1


Sheets("sheet1").Select
Range("A65536").Select
Selection.End(xlUp).Select
lastrow = ActiveCell.Row


Do While currentrow <= lastrow

Range("A" & currentrow).Select
If Trim((ActiveCell.Value)) Like "*Pty*" Or
Trim((ActiveCell.Value)) Like "*Total*" Then

Rows(currentrow).Select
Selection.Delete Shift:=xlUp

Else

currentrow = currentrow + 1

End If

Loop

'Move secondary stock locations to main record

Dim pastecolumn As Integer
Dim looprow As Integer
currentrow = 1
looprow = 1

Sheets("sheet1").Select
Range("A65536").Select
Selection.End(xlUp).Select
lastrow = ActiveCell.Row


Do While looprow <= lastrow

Range("E" & currentrow).Select
If Trim((ActiveCell.Value)) = "" Then

pastecolumn = pastecolumn + 2
ActiveCell.Offset(0, -3).Range("A1:B1").Select
Selection.Cut
ActiveCell.Offset(-1, pastecolumn).Range("A1:B1").Select
ActiveSheet.Paste
Rows(currentrow).Select
Selection.Delete Shift:=xlUp
looprow = looprow + 1

Else

currentrow = currentrow + 1
pastecolumn = 4
looprow = looprow + 1

End If

Loop


End Sub



Could someone see what the problem is please? Your help will be
appreciated!
Thanks
Vas

 

[SeanC UK]

Hi Vas,

Is this simply to continue in the same fashion, each block will contain 3
rows under Pty and 2 columns, that you wish to translate into a block 1 row
by 6 columns. If it will continue in this way, and there won't be a block
consisting of 4 rows by 2 columns, then here is some code that should work
for you (if it is more complicated than this then try to give more details
and I will try to work out a solution for you):

Change the value of the variable lngTotalBlocks to the number of product
blocks that you are processing. I have set it to 2 because that is what is in
your example. Perhaps you can work out a value for this based on the last row
value, so that this is dynamic.

lngOrigFirstRow = the first row of the original data
intOrigFirstColumn = the first column of the original data
lngNewFirstRow = the first row of the new data
intNewFirstColumn = the first column of the original data

Sub CopyCells()
Const lngTotalBlocks As Long = 2
Dim lngBlockCount As Long
Dim intOrigRowCount As Integer
Dim intOrigColumnCount As Integer
Dim intNewColumnCount As Integer
Const lngOrigFirstRow As Long = 4
Const intOrigFirstColumn As Integer = 2
Const lngNewFirstRow As Long = 2
Const intNewFirstColumn As Integer = 5
For lngBlockCount = 1 To lngTotalBlocks
intNewColumnCount = 0
For intOrigRowCount = 0 To 2
For intOrigColumnCount = 0 To 1
Cells(((lngBlockCount - 1) * 6) + lngNewFirstRow, intNewColumnCount +
intNewFirstColumn) = Cells(((lngBlockCount - 1) * 6) + intOrigRowCount +
lngOrigFirstRow, intOrigColumnCount + intOrigFirstColumn)
Cells(((lngBlockCount - 1) * 6) + intOrigRowCount + lngOrigFirstRow,
intOrigColumnCount + intOrigFirstColumn).Clear
intNewColumnCount = intNewColumnCount + 1
Next
Next
Next
End Sub

I hope this helps,

Sean.