I am currently using this code(from a fellow user here) to find every cell in column b1 and to find the ones that contain a ";" something like "hello;goodbye". The code will split the cell at the ";" and place "goodbye" directly beneath "hello;" on an entirely new row..
What I need now is this... if a cell contains multiple ";" (ie "hello;goodbye;yo;hi;hey") it will split at EACH ";" not just the first and then move each to a new row directly beneath the other...
What changes do I need to make?
Dim r1 As Range, r2 As Range
Dim saItem() As String
For Each r1 In ActiveSheet.Range("B1", Cells(Application.Rows.Count, 2).End(xlUp))
If InStr(1, r1.Value2, ";") > 0 Then
saItem = Split(r1.Value2, ";")
r1 = Trim$(saItem(0)) & ";"
r1.Offset(1).EntireRow.Insert (xlDown)
r1.Offset(1) = Trim$(saItem(1))
End If
Next r1
I know it's close to what you have, but I wanted to suggest you use Application.ScreenUpdating. This will save considerable time, especially when inserting/deleting rows in Excel. I also wanted to suggest you change the variable names to somehting a little more meaningful.
Sub SplitCells()
Application.ScreenUpdating = False
Dim strings() As String
Dim i As Long
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If InStr(Cells(i, 2).Value, ";") <> 0 Then
strings = Split(Cells(i, 2).Value, ";")
Rows(i + 1 & ":" & i + UBound(strings)).Insert
Cells(i, 2).Resize(UBound(strings) + 1).Value = _
WorksheetFunction.Transpose(strings)
End If
Next
Application.ScreenUpdating = True
End Sub
P.S. Smaller alterations is to use "2" instad of "B". If you are using cells() instead of Range(), may as well go all the way :)
I found an answer over at
http://www.excelforum.com/excel-programming/802602-vba-macro-to-split-cells-at-every.html
This is the solution I was given:
Sub tgr()
Dim rindex As Long
Dim saItem() As String
For rindex = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If InStr(Cells(rindex, "B").Value, ";") > 0 Then
saItem = Split(Cells(rindex, "B").Value, ";")
Rows(rindex + 1 & ":" & rindex + UBound(saItem)).Insert
Cells(rindex, "B").Resize(UBound(saItem) + 1).Value = WorksheetFunction.Transpose(saItem)
End If
Next rindex
End Sub
Related
Ok so I have two columns of data as follows
Personalisation Max Char | Personaisation Field
1x15x25 | Initial, Name, Date
Previously I was using the following vba function (As excel16 has no TEXTJOIN)
Function TEXTJOIN(delim As String, skipblank As Boolean, arr)
Dim d As Long
Dim c As Long
Dim arr2()
Dim t As Long, y As Long
t = -1
y = -1
If TypeName(arr) = "Range" Then
arr2 = arr.Value
Else
arr2 = arr
End If
On Error Resume Next
t = UBound(arr2, 2)
y = UBound(arr2, 1)
On Error GoTo 0
If t >= 0 And y >= 0 Then
For c = LBound(arr2, 1) To UBound(arr2, 1)
For d = LBound(arr2, 1) To UBound(arr2, 2)
If arr2(c, d) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c, d) & delim
End If
Next d
Next c
Else
For c = LBound(arr2) To UBound(arr2)
If arr2(c) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c) & delim
End If
Next c
End If
TEXTJOIN = Left(TEXTJOIN, Len(TEXTJOIN) - Len(delim))
End Function
This would change 1x15x25 into 1-1, 2-15, 3-25using the following formula
{=TEXTJOIN(", ",TRUE,ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) & " - " & TRIM(MID(SUBSTITUTE(A1,"x",REPT(" ",999)),(ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) -1)*999+1,999)))}
Due to the fact, my original method was not specific enough I've been forced to go back to the drawing board.
From the Above, I am wanting to produce the following.
1-2-Initial, 2-15-Name, 3-25-Date
I am a developer but not in visual basic and the worst part Is I know what I would do with a database and PHP just don't have enough knowledge to transfer that to excel.
So I need to either by formula or function
Take 2 Columns and split by a delimiter
Then count the entries on each (Maybe only one)
Then for each in the range create a new string adding the count-col1-col2
I cannot change the data as its given by the supplier
I have a basic understanding of VBA so explain don't belittle
UPDATED (DATA SNAPSHOTS)
This Example uses the formula above a little-jazzed up.
As you can see each row starts the count again Ignore the Personalization/Message line parts I can add these again later
I am in a mega rush so only whipped this up with one row of values (in A1 and B1)
I hope you can step through to understand it, wrap it in another loop to go through your 6000 rows, and change the msgbox to whatever output area you need... 6000 rows should be super quick:
Sub go()
Dim a() As String
Dim b() As String
Dim i As Long
Dim str As String
' split A1 and B1 based on their delimiter, into an array a() and b()
a() = Split(Range("A1").Value2, "x")
b() = Split(Range("B1").Value2, ",")
' quick check to make sure arrays are same size!
If UBound(a) <> UBound(b) Then Exit Sub
' this bit will need amended to fit your needs but I'm using & concatenate to just make a string with the outputs
For i = LBound(a) To UBound(b)
str = str & i + 1 & "-" & a(i) & "-" & b(i) & vbNewLine
Next i
' proof in the pudding
MsgBox str
End Sub
Sub test()
Dim rngDB As Range
Dim vR() As Variant
Dim i As Long
Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp)) '<~~personaliation Max Char data range
ReDim vR(1 To rngDB.Count, 1 To 1)
For i = 1 To rngDB.Count
vR(i, 1) = textjoin(rngDB(i), rngDB(i, 2))
Next i
Range("c2").Resize(rngDB.Count) = vR '<~ result wil be recorded in Column C
End Sub
Function textjoin(rng1 As Range, rng2 As Range)
Dim vS1, vS2
Dim vR()
Dim i As Integer
vS1 = Split(rng1, "x")
vS2 = Split(rng2, ",")
ReDim vR(UBound(vS1))
For i = LBound(vS1) To UBound(vS1)
vR(i) = i + 1 & "-" & Trim(vS1(i)) & "-" & Trim(vS2(i))
Next i
textjoin = Join(vR, ",")
End Function
THANK YOU FOR ALL OF THE HELP
I went back to the drawing board having seen the above.
I learnt
That my original use of array formula and TEXTJOIN where over the top and hardly simplistic
That I can use VBA just like any other programming code :)
My Solution simplified from Dy.Lee
Function SPLITANDMERGE(arr1 As String, arr2 As String, Optional del1 As String = "x", Optional del2 As String = ",")
'Arr1 Split'
Dim aS1
'Arr2 Split'
Dim aS2
'Value Array'
Dim r()
'Value Count'
Dim v As Integer
'Split The Values'
aS1 = Split(arr1, del1)
aS2 = Split(arr2, del2)
'Count The Values'
ReDim r(UBound(aS1))
'For All The Values'
For v = LBound(aS1) To UBound(aS2)
'Create The String'
r(v) = "Personalisation_Line " & v + 1 & " - " & Trim(aS1(v)) & " Characters - [" & Trim(aS2(v)) & "]"
Next v
'Join & Return'
SPLITANDMERGE = Join(r, ", ")
End Function
I'm still working on it but I now get the following result.
Will Be Adding:
Value Count Comparison (If we have 4 and 5 Values return "-" to be picked up by conditional formatting)
Conditional plural values (If value 2 in the string is 0 then character instead of characters
If there are any pitfalls or errors anyone can see please do enlighten me. Im here to learn.
I have very little experience working with VBA, so I'm having a hard time looking up what I am trying to do because I am having a hard time putting what I am trying to do into words.
I have been struggling to write a code to do the below task for the past few days.
Basically what I am trying to do is to convert a set of data to different format.
This what my source data looks like.
Data:
and I need it to look like this
FinalLook:
I've a already setup a code which is lengthy and incomplete.
FIRST PART
I started with retrieving a part of a data (AQ:BA) and then convert to the format in sheet2 with the below code.
Sub FirstPart()
Dim lastRow As Long
Dim Laaastrow As Long
Sheets("sheet2").Range("a2:A5000").ClearContents
lastRow = Sheets("Sheet1").Range("c" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A2:A" & lastRow).Value = Sheets("Sheet1").Range("c5:c" & lastRow).Value
Sheets("Sheet2").Range("b2:l" & lastRow).Value = Sheets("Sheet1").Range("aq5:ba" & lastRow).Value
End Sub
But.. the problem i am facing with this code is that it pulls all the data, i do not want it to pull all the values, but only the ones which is not empty or 0. In other words, if AQ6:BA6 is empty, script should skip this particular row and go the next one.
SECOND PART (converting the sheet2 data to the final format)
Sub NormalizeSheet()
Dim wsSheet2 As Worksheet
Dim wsSheet4 As Worksheet
Dim strKey As String
Dim clnHeader As Collection
Dim lngColumnCounter As Long
Dim lngRowCounterSheet2 As Long
Dim lngRowCounterSheet4 As Long
Dim rngCurrent As Range
Dim varColumn As Variant
Set wsSheet2 = ThisWorkbook.Worksheets("Sheet2")
Set wsSheet4 = ThisWorkbook.Worksheets("Sheet4")
Set clnHeader = New Collection
wsSheet4.Range("c2:c5000").ClearContents
wsSheet4.Range("e2:e5000").ClearContents
wsSheet4.Range("g2:g5000").ClearContents
lngColumnCounter = 2
lngRowCounterSheet2 = 1
Set rngCurrent = wsSheet2.Cells(lngRowCounterSheet2, lngColumnCounter)
Do Until IsEmpty(rngCurrent.Value)
clnHeader.Add rngCurrent.Value, CStr(lngColumnCounter)
lngColumnCounter = lngColumnCounter + 1
Set rngCurrent = wsSheet2.Cells(lngRowCounterSheet2, lngColumnCounter)
Loop
lngRowCounterSheet2 = 2
lngRowCounterSheet4 = 1
lngColumnCounter = 1
Do While Not IsEmpty(wsSheet2.Cells(lngRowCounterSheet2, lngColumnCounter))
Set rngCurrent = wsSheet2.Cells(lngRowCounterSheet2, lngColumnCounter)
strKey = rngCurrent.Value
lngColumnCounter = 2
Do While Not IsEmpty(wsSheet2.Cells(lngRowCounterSheet2, lngColumnCounter))
Set rngCurrent = wsSheet2.Cells(lngRowCounterSheet2, lngColumnCounter)
If rngCurrent.Value = "NULL" Then
Else
wsSheet4.Range("c" & lngRowCounterSheet4).Offset(1, 0).Value = strKey
wsSheet4.Range("e" & lngRowCounterSheet4).Offset(1, 0).Value = clnHeader(CStr(lngColumnCounter))
wsSheet4.Range("g" & lngRowCounterSheet4).Offset(1, 0).Value = rngCurrent.Value
lngRowCounterSheet4 = lngRowCounterSheet4 + 1
End If
lngColumnCounter = lngColumnCounter + 1
Loop
lngRowCounterSheet2 = lngRowCounterSheet2 + 1
lngColumnCounter = 1
Loop
End Sub
I got this code from another thread posted here on stakcoverflow, i modified a bit to get this work.
The problem i am encountering here is that if Sheet2 B2 is empty, the codes doesnt check sheet C2 instead it skips the whole row, which is not right here.
I know this sounds complicated, and this approach of mine may not be even feasible.
Is there ANY OTHER WAY to do this? Is there any other way to get this in a single shot instead of breaking down the data and move each set of columns to sheet2 then to final format?
See how you get on with this. You'll have to adjust range references, and possibly sheet names
Sub x()
Dim r As Long, c As Range
With Sheet1
For r = 5 To .Range("A" & Rows.Count).End(xlUp).Row
For Each c In .Range(.Cells(r, "AQ"), .Cells(r, "BK")).SpecialCells(xlCellTypeConstants)
If c.Value > 0 Then
Sheet2.Range("A" & Rows.Count).End(xlUp)(2).Value = .Range("B1").Value
Sheet2.Range("B" & Rows.Count).End(xlUp)(2).Value = .Cells(r, 1).Value
Sheet2.Range("C" & Rows.Count).End(xlUp)(2).Value = .Cells(r, 2).Value
Sheet2.Range("D" & Rows.Count).End(xlUp)(2).Value = .Cells(3, c.Column).Value
Sheet2.Range("E" & Rows.Count).End(xlUp)(2).Value = .Cells(4, c.Column).Value
Sheet2.Range("F" & Rows.Count).End(xlUp)(2).Value = "(blank)"
Sheet2.Range("G" & Rows.Count).End(xlUp)(2).Value = c.Value
End If
Next c
Next r
End With
Sheet2.Range("A1").Resize(, 7) = Array("TOPHEADER", "HEADER1", "HEADER2", "FROM", "TO", "TYPE", "UNIT")
End Sub
I have the following Excel cells:
D001
D002
D003
345
(In the same cell)
I need to add a string of text after every line on the same cell, like this:
D001 First Text
D0002 Second Text
D003 Third Text
345 Fouth Text
I found a code which allows me to count how many lines there are on the same cell, but I dont find any way of using it to write after the text on each of those lines:
Public Sub CountLines()
Dim H1 As Double
Dim H2 As Double
Dim row As Long
row = 1
While Cells(row, 1).Value <> ""
With Cells(row, 1)
.WrapText = False
H1 = .height
.WrapText = True
H2 = .height
.Offset(0, 1).Value = H2 / H1
End With
row = row + 1
Wend
End Sub
I guess the right way of doing it is by using a For to write text before any change of line he finds (Ch(10)) on VBA, but i havent been able to make it work
Thanks for the help.
Adding Text To Count Line Breaks
This code will loop through all cells with any value in Column A.
I have recreated your data set in my Excel:
The code will break up each line, add which line it is, and move on to the next:
Below is the code:
Sub AddText()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim myCell As Variant, myRange As Range, tempArr() As String
Dim i As Integer
Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
For Each myCell In myRange
tempArr = Split(myCell, Chr(10))
myCell.Value = ""
For i = 0 To UBound(tempArr)
tempArr(i) = tempArr(i) & " text " & i
If i = UBound(tempArr) Then
myCell.Value = myCell.Value & tempArr(i)
Else: myCell.Value = myCell.Value & tempArr(i) & Chr(10)
End If
Next i
Next myCell
End Sub
If you want it to count from base 1 instead of base 0, change the lines myCell.Value = myCell.Value & tempArr(i) (and the following one in the If statement) to myCell.Value = myCell.Value & tempArr(i) + 1
I should mention again that this is already set up for a dynamic range in Column A. Meaning if you add more data formatted the same way in A2, the code will apply itself to that as well, all the way to the last set of data in column A.
Dim arr() As String
Dim arr2() As String
arr = Split(yourCell, char(10))
arr2 = Split("first, second, third", "," )
For i = 1 To UBound(arr)
debug. print arr(i) + arr2(i)
next i
after rebuilding the new string the new string assign it back to the cell
This will only place (random) text after each line in the cell. But it gives you a place to start.
Option Explicit
Public Sub RePrint()
Dim MyRange As Range
Dim MyArray As Variant
Dim i As Long
Set MyRange = Range("A1")
MyArray = Split(MyRange, Chr(10))
For i = LBound(MyArray) To UBound(MyArray)
MyArray(i) = MyArray(i) & " Text" & i
Next i
MyRange = Join(MyArray, Chr(10))
End Sub
you could use this function:
Function AddText(rng As Range, textsArr As Variant) As String
Dim nTexts As Long, nLines As Long, iLine As Long
Dim linesArr As Variant
nTexts = UBound(textsArr) - LBound(textsArr) + 1
With rng
linesArr = Split(.Value, vbLf)
nLines = UBound(linesArr) - LBound(linesArr) + 1
If nTexts < nLines Then nLines = nTexts
For iLine = 1 To nLines
linesArr(LBound(linesArr) - 1 + iLine) = linesArr(LBound(linesArr) - 1 + iLine) & " " & textsArr(LBound(textsArr) - 1 + iLine)
Next iLine
AddText = Join(linesArr, vbLf)
End With
End Function
to be exploited as follows
Option Explicit
Sub main()
Dim cell As Range
Dim additionalTexts As Variant
additionalTexts = Array("First Text", "Second Text", "Third Text", "Fourth Text") '<--| set your array of additional text, each element index corresponding to to be processed cell content line
With Worksheets("ADDTEXT") '<--| reference your relevant worksheet (change "ADDTEXT" to your actual relevant worksheet name)
For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column "A" cells form row 1 down to last not empty row
cell.Value = AddText(cell, additionalTexts) '<--| process
Next cell
End With
End Sub
This will but in the text "First Line", "Second Line"... after each line. The way it is set up now uses the value in A1 and replaces the value in A1. It is ideal for cells with 4 lines or less, but it will work with more.
Sub appendCharacters()
Dim lines() As String
Dim text As String
lines = Split(Range("A1"), Chr(10))
Range("A1").Value = ""
For i = LBound(lines) To UBound(lines)
Select Case i
Case 0
text = " First Line"
Case 1
text = " Second Line"
Case 2
text = " Third Line"
Case 3
text = " Fourth Line"
Case Else
text = " Another Line"
End Select
lines(i) = lines(i) + text
Range("A1").Value = Range("A1").Value + lines(i)
If i <> UBound(lines) Then
Range("A1").Value = Range("A1").Value + vbCrLf
End If
Next i
End Sub
I'm trying to figure out how to split rows of data where columns B,C,D in the row contain multiple lines and others do not. I've figured out how to split the multi-line cells if I copy just those columns into a new sheet, manually insert rows, and then run the macro below (that's just for column A), but I'm lost at coding the rest.
Here's what the data looks like:
So for row 2, I need it split into 6 rows (one for each line in cell B2) with the text in cell A2 in A2:A8. I also need columns C and D split the same as B, and then columns E:CP the same as column A.
Here is the code I have for splitting the cells in columns B,C,D:
Dim iPtr As Integer
Dim iBreak As Integer
Dim myVar As Integer
Dim strTemp As String
Dim iRow As Integer
iRow = 0
For iPtr = 1 To Cells(Rows.Count, col).End(xlUp).Row
strTemp = Cells(iPtr1, 1)
iBreak = InStr(strTemp, vbLf)
Range("C1").Value = iBreak
Do Until iBreak = 0
If Len(Trim(Left(strTemp, iBreak - 1))) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = Left(strTemp, iBreak - 1)
End If
strTemp = Mid(strTemp, iBreak + 1)
iBreak = InStr(strTemp, vbLf)
Loop
If Len(Trim(strTemp)) > 0 Then
iRow = iRow + 1
Cells(iRow, 2) = strTemp
End If
Next iPtr
End Sub
Here is a link to an example file (note this file has 4 rows, the actual sheet has over 600): https://www.dropbox.com/s/46j9ks9q43gwzo4/Example%20Data.xlsx?dl=0
This is a fairly interesting question and something I have seen variations of before. I went ahead and wrote up a general solution for it since it seems like a useful bit of code to keep for myself.
There are pretty much only two assumptions I make about the data:
Returns are represented by Chr(10) or which is the vbLf constant.
Data that belongs with a lower row has enough returns in it to make it line up. This appears to be your case since there are return characters which appear to make things line up like you want.
Pictures of the output, zoomed out to show all the data for A:D. Note that the code below processes all of the columns by default and outputs to a new sheet. You can limit the columns if you want, but it was too tempting to make it general.
Code
Sub SplitByRowsAndFillBlanks()
'process the whole sheet, could be
'Intersect(Range("B:D"), ActiveSheet.UsedRange)
'if you just want those columns
Dim rng_all_data As Range
Set rng_all_data = Range("A1").CurrentRegion
Dim int_row As Integer
int_row = 0
'create new sheet for output
Dim sht_out As Worksheet
Set sht_out = Worksheets.Add
Dim rng_row As Range
For Each rng_row In rng_all_data.Rows
Dim int_col As Integer
int_col = 0
Dim int_max_splits As Integer
int_max_splits = 0
Dim rng_col As Range
For Each rng_col In rng_row.Columns
'splits for current column
Dim col_parts As Variant
col_parts = Split(rng_col, vbLf)
'check if new max row count
If UBound(col_parts) > int_max_splits Then
int_max_splits = UBound(col_parts)
End If
'fill the data into the new sheet, tranpose row array to columns
sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)
int_col = int_col + 1
Next
'max sure new rows added for total length
int_row = int_row + int_max_splits + 1
Next
'go through all blank cells and fill with value from above
Dim rng_blank As Range
For Each rng_blank In sht_out.Cells.SpecialCells(xlCellTypeBlanks)
rng_blank = rng_blank.End(xlUp)
Next
End Sub
How it works
There are comments within the code to highlight what is going on. Here is a high level overview:
Overall, we iterate through each row of the data, processing all of the columns individually.
The text of the current cell is Split using the vbLf. This gives an array of all the individual lines.
A counter is tracking the maximum number of rows that were added (really this is rows-1 since these arrays are 0-indexed.
Now the data can be output to the new sheet. This is easy because we can just dump the array that Split created for us. The only tricky part is getting it to the right spot on the sheet. To that end, there is a counter for the current column offset and a global counter to determine how many total rows need to be offset. The Offset moves us to the right cell; the Resize ensures that all of the rows are output. Finally, Application.Transpose is needed because Split returns a row array and we're dumping a column.
Update the counters. Column offset is incremented every time. The row offset is updated to add enough rows to cover the last maximum (+1 since this is 0-indexed)
Finally, I get to use my waterfall fill (your previous question) on all of the blanks cells that were created to ensure no blanks. I forgo error checking because I assume blanks exist.
Thank you for providing a sample. This task was so interesting that I thought of writing the code for that. You are more than welcome to tweak it to your satisfaction, and I hope your team gets to use an RDBMS to manage this kind of data in the future.
Sub OrganizeSheet()
Dim LastRow As Integer
LastRow = GetLastRow()
Dim Barray() As String
Dim Carray() As String
Dim Darray() As String
Dim LongestArray As Integer
Dim TempInt As Integer
Dim i As Integer
i = 1
Do While i <= LastRow
Barray = Split(Range("B" & i), Chr(10))
Carray = Split(Range("C" & i), Chr(10))
Darray = Split(Range("D" & i), Chr(10))
LongestArray = GetLongestArray(Barray, Carray, Darray)
If LongestArray > 0 Then
' reset the values of B, C and D columns
On Error Resume Next
Range("B" & i).Value = Barray(0)
Range("C" & i).Value = Carray(0)
Range("D" & i).Value = Darray(0)
Err.Clear
On Error GoTo 0
' duplicate the row multiple times
For TempInt = 1 To LongestArray
Rows(i & ":" & i).Select
Selection.Copy
Range(i + TempInt & ":" & i + TempInt).Select
Selection.Insert Shift:=xlDown
' as each row is copied, change the values of B, C and D columns
On Error Resume Next
Range("B" & i + TempInt).Value = Barray(TempInt)
If Err.Number > 0 Then Range("B" & i + TempInt).Value = ""
Err.Clear
Range("C" & i + TempInt).Value = Carray(TempInt)
If Err.Number > 0 Then Range("C" & i + TempInt).Value = ""
Err.Clear
Range("D" & i + TempInt).Value = Darray(TempInt)
If Err.Number > 0 Then Range("D" & i + TempInt).Value = ""
Err.Clear
On Error GoTo 0
Application.CutCopyMode = False
Next TempInt
' increment the outer FOR loop's counters
LastRow = LastRow + LongestArray
i = i + LongestArray
End If
i = i + 1
Loop
End Sub
' ----------------------------------
Function GetLongestArray(ByRef Barray() As String, ByRef Carray() As String, ByRef Darray() As String)
GetLongestArray = UBound(Barray)
If UBound(Carray) > GetLongestArray Then GetLongestArray = UBound(Carray)
If UBound(Darray) > GetLongestArray Then GetLongestArray = UBound(Darray)
End Function
' ----------------------------------
Function GetLastRow() As Integer
Worksheets(1).Select
Range("A1").Select
Selection.End(xlDown).Select
GetLastRow = Selection.Row
Range("A1").Select
End Function
Give it a shot!
I have an excel sheet of which the data was jumbled: for example, the data that should have been in Columns AB and AC were instead in Columns B and C, but on the row after. I have the following written which moved the data from B and C to AB and AC respectively:
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("A:A")
i = 1
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each rCell In rRng.Cells
If rCell.Value = "" Then
Range("AB" & i) = rCell.Offset(0, 1).Value
rCell.Offset(0, 1).ClearContents
End If
i = i + 1
If i = lastRow + 1 Then
Exit Sub
End If
Next rCell
End Sub
However, it doesn't fix the problem of the data being on the row BELOW the appropriate row now that they are in the right columns. I am new to VBA Macros so I would appreciate any help to make the data now align. I tried toggling the Offset parameter (-1,0) but it's not working.
Try something like this?
For i = Lastrow To 1 Step -1
' move data into cell AA from Cell A one row down
Cells(i, 27).Value = Cells(i + 1, 1).Value
Next
You don't need to loop through the range to accomplish what you're trying to do.
Try this instead:
Sub MoveBCtoAbAcUpOneRow()
Dim firstBRow As Integer
Dim lastBRow As Long
Dim firstCRow As Integer
Dim lastCRow As Long
' get the first row in both columns
If Range("B2").Value <> "" Then
firstBRow = 2
Else
firstBRow = Range("B1").End(xlDown).Row
End If
If Range("C2").Value <> "" Then
firstCRow = 2
Else
firstCRow = Range("C1").End(xlDown).Row
End If
' get the last row in both columns
lastBRow = Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row
lastCRow = Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
' copy the data to the correct column, up one row
Range("B" & firstBRow & ":B" & lastBRow).Copy Range("AB" & firstBRow - 1)
Range("C" & firstCRow & ":C" & lastCRow).Copy Range("AC" & firstCRow - 1)
' clear the incorrect data
Range("B" & firstBRow & ":B" & lastBRow).ClearContents
Range("C" & firstCRow & ":C" & lastCRow).ClearContents
End Sub
Notes:
If the shape of data in each column is the same, you don't need to
find the first and last row for each. You'll only need one variable for each and one copy operation instead of 2.
Make sure you set variable declaration to required.
(Tools -> Options -> Require Variable Declaration) You may already be doing this, but I couldn't tell because it looks like the top of your Sub got truncated.