1

I have the following column (1):

1 15 150 1500000 06700 07290 07500 2 22 220 2200000 00900

This would need to become 2 columns

1 15 150 1500000 06700 1500000 07290 1500000 07500 2 22 220 2200000 00900

My initial idea:

  • Create the extra column.
  • Looping through the rows, register the cell and value in variables when a number with lenght of 7 digits is found.
  • Move the values under it to column B until the lenght of values is <> 5
  • Start from cell saved in variable and copy value from variable to column A until column A is no longer Empty
  • After the above proces, loop rows and delete where A is lenght 7 and B is empty.

As i am not familiar with VBA, before i plunge into, i would like to verify this above set of rules would do what i intend it to do, if it's technically feasable with VBA macro's and wether or not it could result to unexpected behaviour.

This code would have to run every month on a new large excel file.

Improve this question
5
  • 1
    Interesting project and you've written a decent software specification but it still a software specification and SO is not a free code writing service. Get started with the macro recorder and come back to edit your question to include your own effort when you run into trouble reforming the recorded code for the larger purpose. Commented Nov 17, 2015 at 10:50
  • Thank you for reading, i am not requesting code nor review of code. I'm asking wether my logic has flaws and if i have forgotten an important step that would kill functionality once written. I am currently reading and learning to write the above. Commented Nov 17, 2015 at 11:03
  • Your logic will work but it can be optimized. A 2-dimension variant array would be faster and the rows could be deleted in one piece instead of many small pieces. Once thing that stands out is you reliance on the length. Are 00900, etc formatted as Text or is that cell number formatting of 00000 to achieve the leading zeroes? When you walk through the rows, start at the bottom and work to the top. Commented Nov 17, 2015 at 11:10
  • They are indeed formatted as text. Think you found an interesting flaw in my logic there. As soon as i do a trim it isn't considered text anymore. I need to keep the leading 0. I use Dim Cell As Range For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells x = x + 1 Cell.Value = WorksheetFunction.Trim(Cell.Value) Next Cancel the above, force putting it to text again before trimming does the trick. Commented Nov 17, 2015 at 11:30
  • There is a Range.Text property, a Range.Value property and a Range.Value2 property. The .Text is the displayed text so it could be either a text string of 5 characters or it could be a number formatted as 00000. Commented Nov 17, 2015 at 11:48

2 Answers 2

Reset to default
1

Whether your 5 digit (c/w/ leading zeroes) numbers are true numbers with a cell formatting of 00000 or text-that-look-like-numbers with a Range.PrefixCharacter property, the Range.Text property should be able to determine their trimmed length from the displayed text.

The following code follows your logic steps with a few modifications; the most obvious one is that it walks from the bottom of column A to the top. This is to avoid skipping rows that have been deleted.

Sub bringOver() Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant 'put the cursor anywhere in here and start tapping F8 'it will help if you can also see the worksheet with your 'sample data ReDim vVAL5s(0) 'preset some space for the first value With Worksheets("Sheet1") '<~~ set this worksheet reference properly! 'ensure a blank column B .Columns(2).Insert 'work from the bottom to the top when deleting rows 'or you risk skipping a row For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 'determine the length of the trimmed displayed length 'and act accordingly Select Case Len(Trim(.Cells(rw, 1).Text)) Case Is < 5 'do nothing Case 5 'it's one to be transferred; collect it vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text 'make room for the next ReDim Preserve vVAL5s(UBound(vVAL5s) + 1) Case 7 'only process the transfer if there is something to transfer If CBool(UBound(vVAL5s)) Then 'the array was built from the bottom to the top 'so reverse the order in the array ReDim vREV5s(UBound(vVAL5s) - 1) For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1 vREV5s(UBound(vREV5s) - v) = vVAL5s(v) Next v 'working With Cells is like selecting htem but without selecting them 'want to work With a group of cells tall enough for all the collected values With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1) 'move over to column B and put the values in .Offset(0, 1) = Application.Transpose(vREV5s) 'make sure they show leading zeroes .Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]@" 'if there was more than 1 moved over, FillDown the 7-wide value If CBool(UBound(vREV5s)) Then .FillDown 'delete the last row .Cells(.Rows.Count + 1, 1).EntireRow.Delete End With 'reset the array for the next first value ReDim vVAL5s(0) End If Case Else 'do nothing End Select 'move to the next row up and continue Next rw 'covert the formatted numbers to text Call makeText(.Columns(2)) End With End Sub Sub makeText(rng As Range) Dim tCell As Range For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers) tCell.Value = Format(tCell.Value2, "\'00000;@") Next tCell End Sub

Just before exiting the primary routine, the short helper sub is called using column B as a range of cells. This will loop through all of the numbers in column B and convert the numbers into text with leading zeroes.

As noted in the code comments, set yourself up so you can see the code sheet as well as a portion of your worksheet and start tapping F8 to step through the code. I've tried to add a form of running commentary with the notes left above many of the code lines.

Improve this answer
Sign up to request clarification or add additional context in comments.

Comments

1

After writing the logic keeping in mind Jeeped's input i ended up making it the following way:

  • Force convert the column A to definately be Text
  • Create the extra column.
  • Get the number of rows with data
  • Loop 1: If column A cell lenght is 5, move cell to column B
  • Loop 2: If column A cell lenght is 7, we copy the value to variable.
  • Loop 2: If column A cell lenght is 0, we paste variable to the cell
  • After the above proces, loop rows and delete where A is lenght 7 and B is empty. (reverse loop for performance)

All input on the below posted code is more than welcome. I'm open for every kind of possible optimization.

 Sub FixCols() 'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim Range("A:A").NumberFormat = "@" Dim Cell As Range For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells x = x + 1 Cell = Trim(Cell) Cell.Value = WorksheetFunction.Trim(Cell.Value) Next 'Now insert empty column as B Columns("B:B").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'Determine rows with values for loop With ActiveSheet LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With 'Loops to move around the data Dim i As Long Dim CellValue As Long For i = 1 To LastRow 'move items to column B If Len(Range("A" & i).Value) = 5 Then Range("A" & i).Select Selection.Cut Range("B" & i).Select ActiveSheet.Paste End If Next i For i = 1 To LastRow 'if the row is a reknr we copy the value If Len(Range("A" & i).Value) = 7 Then CellValue = Range("A" & i).Value End If 'Paste the reknr to the rows with item If Len(Range("A" & i).Value) = 0 Then Range("A" & i).Value = CellValue End If Next i 'Reverse loop (performance) to check for rows to delete (reknr without item) i = LastRow Do If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then Rows(i).Delete End If i = i - 1 Loop While Not i < 1 End Sub
Improve this answer

1 Comment

I had a little trouble with this the first time but that was because my numbers were only formatted as 00000; once I changed them to text everything seemed to work well.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.