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.
--
(please remember to click yes if replies you receive are helpful to you)
"vasileib7" wrote:
> 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
>
>
|
Similar Threads
