How to remove a certain value from a table that will vary in size in Excel - vba

I'm new to the community and I apologize if there is a thread elsewhere, but I could not find it!
I'm currently diving into VBA coding for the first time. I have a file that I dump into a worksheet that currently I'm manually organizing and pushing out. When put into the worksheet, it delimits itself across the cells. This dump file will have varying row and column lengths every time I get it in a given day and dump into a work sheet. For example, one day it may be twenty rows and one day it may be thirty.
A certain roadblock in my VBA code creation process has presented itself. I'm trying to create a code that will parse through the worksheet to remove any time a certain value appears (See below image - I'm referring to the (EXT)). After doing so I'm trying to concatenate the cells in the row up until there is a space (which with the rows that have (EXT), there usually isn't a space after until the (EXT) is removed).
The code I made works for now but I recognize it's not very efficient and not reliable if the names extend longer than two cells. I was hoping someone on here could provide me with guidance. So, I'm looking for two things:
For the code to scan the whole active used range of the table and remove (EXT). As it may appear in various columns.
A way to concatenate the cells in every row in the active range from A to the cell before a blank cell
Keep in mind I have no coding background, I'm learning and I'm not familiar with VBA terms and whatnot all that much just yet - so if you could please explain in laymen's terms I'd appreciate it. I hope all of this makes sense... Thanks in advance!
This is just an example of part of what the dump code looks like, so my code probably doesn't match with the example below - I just wanted to provide a visual:
http://i.imgur.com/IwDDoYd.jpg
The code I currently have:
Sub DN_ERROR_ORGANIZER()
' Removes any (EXT) in Column 3 in actual dump data file
For i = 200 To 1 Step -1
If (Cells(i, 3).value = "(EXT)") Then
Cells(i, 3).Delete Shift:=xlToLeft
End If
Next i
' Removes any (EXT) in Column 4 in actual dump data file
For j = 200 To 1 Step -1
If (Cells(j, 4).value = "(EXT)") Then
Cells(j, 4).Delete Shift:=xlToLeft
End If
Next j
' Removes any (EXT) in Column 5 in actual dump data file
For k = 200 To 1 Step -1
If (Cells(k, 5).value = "(EXT)") Then
Cells(k, 5).Delete Shift:=xlToLeft
End If
Next k
' Places a new column before A and performs a concatenate on cells B1 and C1 to
' form a name, then copies all through column A1 to repeat on each row
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "=PROPER(CONCATENATE(RC[1],"", "", RC[2]))"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:A51")
Range("A1:A51").Select
End Sub

edited: to keep the comma after the first "name" only
this should do:
Sub main()
Dim cell As Range
With Worksheets("names")
With Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In .Rows
cell.Cells(1, 2).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(cell.Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
just remember to change "names" to you actual worksheet name
edited 2:
code for stopping cells to be processed at every line at the last one before the first blank one
Sub main()
Dim cell As Range, dataRng As Range
With Worksheets("names") '<--| change "names" to you actual worksheet name
Set dataRng = Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In dataRng.Columns(1).Cells
cell.Offset(, 1).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(.Range(cell, cell.End(xlToRight)).Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
With dataRng
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub

I believe you are quite close to achieve what you are asking for and, based on your request, I will not give you a solution but some guidance to complete it by yourself.
First 3 loops: You could simplify by having a single set of nested loops: An outer loop running from 3 to 5, an inner loop running from 200 to 1; the outer loop will run over index, say "p", the inner over index, say "q", and your reference to cells would become Cells(q,p). If you need to run this over more than 3 rows, just start the outer loop from, say, 3 and till, say 10000 (being 10000 the maximal number of rows your data may display) and add a condition that if the first cell of the row is empty, you exit the outer loop.
The second part (this is what I understood) is to take the 2-3 first cells and concatenate them into a new cell (i.e. the column you add at the left). Once again, you can just loop over all your rows (much the same as in the outer loop mentioned above), except that now you will be looking at the cells in columns 2-4 (because you added a column at the left). The same exit condition as above can be used.
I'm not sure if this is what you were looking for, but this is what I understood you were looking for.

After reading user3598756's answer, I realized that I missed the boat with my original answer.
Sub DN_ERROR_ORGANIZER()
Dim Target As Range
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
With Target.Offset(0, Target.Columns.Count).Resize(, 1)
.FormulaR1C1 = "=PROPER(C1&"", ""&TEXTJOIN("" "",TRUE,RC[-" & (Target.Columns.Count - 1) & "]:RC[-1]))"
.Value = .Value
End With
Target.Delete
End Sub
UPDATE
If you are running an older version of Excel that doesn't support TEXTJOIN then use this:
Sub DN_ERROR_ORGANIZER()
Dim Data
Dim x As Long, y As Long
Dim Target As Range
Dim Text As String
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
Data = Target.Value
For x = 1 To Target.Rows.Count
Data(x, 1) = Data(x, 1)
For y = 2 To Target.Columns.Count
If Data(x, y) <> vbNullString Then Text = Text & " " & Data(x, y)
Next
If Len(Text) Then Data(x, 1) = Data(x, 1) & "," & Text
Text = vbNullString
Next
Target.ClearContents
Target.Columns(1).Value = Data
End Sub

Related

Merging Cells row by row without losing any data

I'm getting data that is in 1, 2, or 3 columns (possibly more). I need each row to combine the data in the respective row without losing any of the data from any columns.
I managed to get some code together that will combine the cells properly, but I'm struggling to use this code to look through each row and combine the cells in that row, for all rows that contain data.
Here is what I have so far:
Sub JoinAndMerge()
'joins all the content in selected cells
'and puts the resulting text in top most cell
'then merges all cells
Dim outputText As String
Const delim = " "
On Error Resume Next
For Each cell In Selection
outputText = outputText & cell.value & delim
Next cell
With Selection
.Clear
.Cells(1).value = outputText
.Merge
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
End With
End Sub
And here's what I've got as far as trying to get it to look through each row.
Sub JoinAndMerge2()
'joins all the content in selected cells
'and puts the resulting text in top most cell
'then merges all cells
Dim outputText As String
Const delim = " "
On Error Resume Next
Dim cell_value As Variant
Dim counter As Integer
Dim xlastRow As Long
Dim xlastColumn As Long
xlastRow = Worksheets("Sheet48").UsedRange.Rows.Count
xlastColumn = Worksheets("Sheet48").UsedRange.Columns.Count
'Looping through A column define max value
For i = 1 To xlastRow
'Row counter
counter = 1
'Take cell one at the time
cell_value = ThisWorkbook.ActiveSheet.Cells(1, i).value
For Each cell In Selection
outputText = outputText & cell.value & delim
Next cell
With Selection
.Clear
.Cells(1).value = outputText
.Merge
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
End With
counter = counter + 1
Next i
End Sub
How do I get this to loop properly through each row?
If it helps, before on left, after on right:
I never recommend merging cells, but if you must...
This is dynamic by row (determined by Column A) and column. Each merge size is dependent on each rows furthest right non-blank column. Therefore, some merged cells will span 2 columns and some will span 3. If you don’t want that to be the case, you will need to find the max used column and merge by that column index
I.E. replacing MyCell.Resize(1, i -1).Merge with MyCell.Resize(1, MaxCol).Merge where MaxCol is your max used column.
Option Explicit
Sub Merger()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim MyCell As Range, Merged As String, i, iArr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each MyCell In ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For i = 1 To ws.Cells(MyCell.Row, ws.Columns.Count).End(xlToLeft).Column
Merged = Merged & Chr(32) & MyCell.Offset(, i - 1) 'Build String
Next i
MyCell.Resize(1, i - 1).Merge 'Merge
MyCell = Right(Merged, Len(Merged) - 1) 'Insert String
Merged = "" 'Reset string for next loop
MyCell.HorizontalAlignment = xlGeneral
MyCell.VerticalAlignment = xlCenter
MyCell.WrapText = True
Next MyCell
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
It can't be stressed too much. Merged cells should be avoided.
They play havoc when dragging an area to populate cells. They interrupt the double click autofill and make copying and pasting an exercise in frustration. They delay development and add complexity to formulas and VBA code all the while creating more opportunities for an error to occur or a bug to go unnoticed.
So i urge you to reconsider using merged cells.
Almost to prove the point, you'll find "*****" on a few lines in the two solutions below. Each one of those lines needs to be handled uniquely. Care to guess why? The merged cell you currently have in row 1. That merged cell can cause those lines to either halt with an error or continue with the possibility of unwanted consequences depending on which cell addresses actually hold row 1 data.
Merged cells are absolutely horrid and considered among the greatest of Excel sins.
Here are two ways forward without merged cells...
In VBA (psuedo code)
For (Columns, 2, LastColumn, Step 2)
For(Rows, 3, LastRow)
With Worksheet
If .Cells(Row,Column) <> vbNullString then
.cells(Row,Column-1)=.cells(Row,Column-1).Value2 _
& StringDeliminator & .cells(Row,Column).Value2
End If
End with
Next Rows
Columns (Column).EntireColumn.Delete*****
Next Columns
Using formulas in a worksheet
Add a new column C
In cell C3 use the formula
=If(A3<>"",C3=A3 & " " & B3,"")
Drag the formula down(copy to other columns if needed)
Ctrl Shift Up to select all the formulas
Copy *****
Paste Special Values *****
Delete columns A and B *****
There is one situation where merged cells are ok...
if you're in a situation where you're against the wall, there is nothing you can do because your manager doesn't care if your work is incompatible with his analyst's automation tools and refuses to accept center across selection as a viable alternative because "i know what center does and it does not help, you have to merge cells to get the text centered over those columns ".... if this is your situation then merged cells are ok, just use this method:: first, start looking for another job (or a promotion above your manager, your company should already be looking) and second, submit the broken merged cell version to the snowflake and quitely slip the functional version to your analyst as a preliminary estimate
That's the only time I authorize you to use merged cells.

copy cell content based if adjacent cell meets criteria

I have a series of matrices consisting of 7 columns with a varied number of rows. I want the company names that are in column 2 of the matrix if the corresponding data in column 4 is "CM" aggregated into one cell per matrix (lets say B3:B98 for all the different matrices) with a space in between the different names. Please see the below picture for an example of what the matrices look like
The end result is that all the company names in Column E will be aggregated in B3 if the cell on the same row in column G is "CM", the next matrix beginning in Column M in B4 and so on.
I am having zero success in getting my if statement to recognize "CM" in the cell content, or aggregating the results using the Join statement. Any help is much appreciated.
Edits:
The objective is to have all the underwriters on a particular security aggregated in one cell, so that the cell can be easily searched in another part of the sheet for the presence of a particular underwriter.
The code below, as you can likely tell, does not work. I hit a wall as I could not get it to distinguish between cells that contained "CM" and those that did not. (I know that the code below would not aggregate the result in any cell, only copying the result into column B, as I said, it is a work in progress that has stalled.)
Dim Ws5 As Worksheet: Set Ws5 = Worksheets(5)
'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Compiles the managers in the matrices into a column on the MgrMatrix sheet to be used
'for the entry sheet column of underwriters.
Dim CoL As Range: Set CoL = Ws5.Range("D3:K104")
Dim CeL As Range
For Each CeL In CoL.Columns(4)
If CeL.Text = "CM" Then
CeL.Offset(0, -5) = "CM"
Else
CeL.Offset(0, -5) = CeL.Offset(0, -2).Value
End If
Next
Edit: Using urdearboy's code, i modified it to work for multiple matrices on the same sheet in the below way. This version doesn't have the same finesse as his did, as this version relies on all matrices containing the same number of columns and not exceeding 100 rows.
For i = 7 To 857 Step 9
For y = 3 To 100
If Cells(y, i) = "CM" Then
s = s & Cells(y, i).Offset(0, -1).Value & " "
End If
Next y
If s = "" Then
s = "Sole Lead"
End If
Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = Trim(s)
s = ""
Next i
Paste code in VBE within Sheet 5 (Or whatever sheet you want to run this on).
The string, s, will build itself as it loops through your column checking for "CM" matches.
As is, the code will add commas between each new value added like, so, and, so, and then remove the last coma at the end before displaying the final string like, so, and, so
Option Explicit
Sub TextCM()
Dim i As Long, s As String
For i = 3 To Range("G" & Rows.Count).End(xlUp).Row
If Range("G" & i) = "CM" Then
s = s & Range("E" & i).Value & ", " 'Remove & ", " if you do not want the comma + space
End If
Next i
Range("B2") = Left(s, Len(s) - 2) 'Change to Range("B2") = s to not delete last character in string
End Sub
You should be able to figure out how to extend this to multiple tables (matrices?) no problem.

Using VBA to Add Rows based on a cell value onto another worksheet

I am trying to create a spreadsheet whereby I have a value in a cell in a worksheet called "Equipment" cell C5, for example a Value of 4.
Starting Cell Image
I need to use this value to copy a section of the same row (D5:M5) and paste it that many times into a worksheet called "Programming" also if this changes I would like it to delete or add where required, ignoring where there is a blank or 0 value in the "equipment" sheet
Desired Result
I have around 30 different items and all will have different sections to copy but they will be of the same size. Also Could this look down a list of values all in the same column and do the same for all the values
I'm very new to VBA and have managed to hide and show tabs based on values but i'm struggling to get my head around this as it's a little too complicated at this point.
Thank You in advance
Lee
This is what I have so far, I have edited the code to what I believe is correct but it still isn't working
Sub copySheetCells()
'loop by each cell in column "C"
For i = 2 To Sheets("Equipment").Cells(Rows.Count, "C").End(xlUp).Row
'repeat copy x times (based on cell in column "C" value)
For j = 0 To (Sheets("Equipment").Cells(i, "C").Value - 1)
'define source range
Source = "D" & (i) & ":M" & (i)
'find last row on second sheet
lastRowS2 = Sheets("Hardware_Programming").Cells(Rows.Count, "A").End(xlUp).Row
'copy data
Sheets("Equipment").Range(Source).copy Destination:=Sheets("Hardware_Programming").Range("A" & lastRowS2 + 1)
Next j
Next i
'copy headers
Sheets("Equipment").Range("D1:M1").copy Destination:=Sheets ("Hardware_Programming").Range("A1:J1")
End Sub
I only get blank spaces, is anyone able to advise any further?
Here you go, use this macro. Based on names Programming and Equipment as originally requested.
Sub copySheetCells()
'loop by each cell in column "C"
For i = 2 To Sheets("Programming").Cells(Rows.Count, "C").End(xlUp).Row
'repeat copy x times (based on cell in column "C" value)
For j = 0 To (Sheets("Programming").Cells(i, "C").Value - 1)
'define source range
Source = "D" & (i) & ":M" & (i)
'find last row on second sheet
lastRowS2 = Sheets("Equipment").Cells(Rows.Count, "A").End(xlUp).Row
'copy data
Sheets("Programming").Range(Source).copy Destination:=Sheets("Equipment").Range("A" & lastRowS2 + 1)
Next j
Next i
'copy headers
Sheets("Programming").Range("D1:M1").copy Destination:=Sheets("Equipment").Range("A1:J1")
End Sub
EDIT
Please avoid copying the code from the answer and posting it back at your question, I replaced the Sheet1 with Programming so you can rename that sheet in your workbook.
Macro seems to do what it does, the quantity in Sheet1/Programming was not provided (column "C" according to your initial requirements):
Source (with added quantity)
Result:
Hope this will solve your problem :)
For i = 1 To 30 Step 1
If Sheets("Equipment").Cells(1 + 4, 3).Value > 0 Then
Sheet1.Range(Cells(i + 3, 5), Cells(i + 3, 13)).Copy
For j = 1 To Sheet1.Cells(1 + 4, 3).Value Step 1
LR = Sheets("Programming").Cells(Sheets("Programming").Rows.Count, "A").End(xlUp).Row
Sheets("Programming").Range("A" & LR + 1).PasteSpecial Paste:=xlPasteValues
Next
End If
Next
Cheers ;)

How can I make this VBA loop (for each cell, copy paste) faster?

I have a piece of code that is taking up a large amount of the actual runtime. It seems like this loop actually makes Excel unresponsive at times (not 100% sure about this, but this seems to me the most likely culprit when I stepped through the code). Anyways, I want to optimize this piece of code so it doesn't take so long.
Some background:
EDIT: application.screenupdating is set to false
Sheets(1) = RawData
Sheets(2) = AreaTable
j=2 before entering the loop
rng is the range including all values in sheet1 column CJ minus the header
In sheet1 column CJ is a list of ComponentNames that I want to loop through. For each ComponentName, I want to filter column AL and copy paste (transpose) all the visible values in column AL (there will always be at least >1 value) to Sheets(2).
There are usually around 1000-1200 ComponentNames and anywhere from 10-240 values (the same values that I'm copy pasting to sheet2) for each ComponentName.
For Each cell In rng
ComponentName = cell.Value
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=ComponentName
RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1
Next cell
What changes can I make to this loop to get the process done faster?
Build an array of the ComponentName values and filter & copy/paste once instead of a thousand times.
Dim v As Long, vCOMPNAMEs As Variant
With rng
ReDim vCOMPNAMEs(.Count)
For v = LBound(vCOMPNAMEs) To UBound(vCOMPNAMEs)
vCOMPNAMEs(v) = rng.cells(v + 1).Value2
Next v
End With
With RawData
.Range("A:CJ").AutoFilter Field:=17, Criteria1:=vCOMPNAMEs, Operator:=xlFilterValues
.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1 '<~~?????
End With
you may try something like that:
Dim outputVal As Variant, chkRng As Variant, valRng As Variant
Dim i As Long, j As Long, k As Long
With rawdata
k = .Cells(Rows.Count, 38).End(xlUp).Row
chkRng = .Range("Q2:Q" & k).Value
valRng = .Range("AL2:AL" & k).Value
ReDim outputVal(rng.Count, 0)
For Each cell In rng.Value
k = 0
For i = LBound(chkRng) To UBound(chkRng)
If chkRng(i, 1) = cell Then
outputVal(j, k) = valRng(i, 1)
k = k + 1
If k > UBound(outputVal, 2) Then ReDim Preserve outputVal(rng.Count, k)
End If
Next
j = j + 1
Next
End With
With areatable: .Range(.Cells(1, 2), .Cells(rng.Count + 1, UBound(outputVal, 2) + 2)).Value = outputVal: End With
pls test it with a copy... not having the real workbook may completely mess everything up... but it will probably end in an error...
pls try it and then tell what went wrong :)
EDIT
tested it with a small table and it worked perfectly (and also pretty fast), however: without a small example-workbook its hard to check if it will also work for you
EDIT2
the way it works: when looking for speed you need to know that everything a sheet need to do is slow. so the first part simply gets all the values to check/copy whatever and put them in variables (which is much faster in reading/writing). (chkRng and valRng)
then i generate a variable for the outputs (outputVal)
knowing there is only 1 value to check (filter) i also can compare the column with your cell. and everytime it finds a match the other value (same position) is put into the output-value (and resizing the value if needed).
lastly it pastes the outputvalue in the desired range in one step.
main downsides:
- no format will be copied (only the values, but could be changed to also copy formulas, while there is no need here)
- you need to know the exact range (to small and values will be missing / to big and an errorcode will be in each cell outside of the variable-range)
Turn calculation off before you run this, because everytime you filter, it recalculates the workbook, and if there are a lot of formulas then that will eat away at your processors:
Application.Calculation = xlCalculationManual
For Each cell In Rng
ComponentName = cell.Value
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=ComponentName
RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1
Next cell
Application.Calculation = xlCalculationAutomatic
David's suggestion is what I was going to post, that will help a lot. Also, try this (not assigning ComponentName). Untested, but should work:
For Each cell In rng
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=cell.Value
RawData.Range("AL2", Range("AL2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible).Copy
AreaTable.Range("B" & j).PasteSpecial Transpose:=True
j = j + 1
Next cell
It might also be faster to store into an array... unfortunately I don't know how many cells you're copying in... but I'll assume you're copying in 2 cells in this example, change as per your needs. Anyway, you could store results into an array and then spit out results all at once, like this:
dim arr(300000,1)
For Each cell In rng
RawData.Range("A:CJ").AutoFilter field:=17, Criteria1:=cell.Value
arr(j,0) = RawData.Range("AL2")
arr(j,1) = RawData.Range("AL2").offset(1,0)
' etc.... do this for each (or create a loop to capture everything)
j = j + 1
Next cell
for j_ctr = 1 to j
AreaTable.Range("B" & j).value=arr(j_ctr,0)
AreaTable.Range("B" & j+1).value=arr(j_ctr,1)
next
unless the expensive part is the autofiltering... any way to avoid this?

Variable searching cells VBA

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.
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.
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