Related
I am trying to copy values from once column to another using vba. I am using the follwoing vba script:
Private Sub Import_Click()
Worksheets("test").Range("D10:D49") = Worksheets("test2").Range("G22:G61").Value
End Sub
But this just copies the values from one column to another. My question is this, consider the example below:
I want to copy the "Num" from table 1 to table 2 by matching it with the "items". Is there a way to do it using VBA? cuz, my actual list is really long.
If you are dealing with a large number of data and want to use VBA you can use dynamic arrays.
Try this example :
I have reproduced your example assuming first table is located on columns A & B, and 2nd one E & F (boths on first line):
Sub lookup_with_arrays()
Dim wb As Workbook
Dim ws As Worksheet
Dim arr1(), arr2() As Variant
Dim lastrow_arr1, lastrow_arr2, i, j As Long
Set wb = Workbooks("Your_File.xlsm")
Set ws = wb.Worksheets("Your_Sheet")
lastrow_arr1 = Range(ws.Cells(1, 1), ws.Cells(1, 1).End(xlDown)).Rows.Count
lastrow_arr2 = Range(ws.Cells(1, 5), ws.Cells(1, 5).End(xlDown)).Rows.Count
'Set dynamic dimensions
ReDim arr1(1 To lastrow_arr1, 1 To 2)
ReDim arr2(1 To lastrow_arr2, 1 To 2)
'Indicate which data to set up in the arrays
For i = LBound(arr1) To UBound(arr1)
arr1(i, 1) = ws.Cells(i, 1)
arr1(i, 2) = ws.Cells(i, 2)
Next i
For i = LBound(arr2) To UBound(arr2)
arr2(i, 1) = ws.Cells(i, 5)
arr2(i, 2) = ws.Cells(i, 6)
Next i
'Now we can match both Items colums and complete arr2 second column
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
If arr1(i, 1) = arr2(j, 1) Then
arr2(j, 2) = arr1(i, 2)
Exit For
End If
Next j
Next i
'Then you can report arr2 in your worksheet
For i = 2 To UBound(arr2)
ws.Cells(i, 6) = arr2(i, 2)
Next i
End Sub
Another option would be to use a Vlookup function :
Function VLOOKUP(TheValueYouNeed As Variant, RangeOfSearch As Range, No_index_col As Single, Optional CloseValue As Boolean)
On Error GoTo VLookUpError
VLOOKUP = Application.VLOOKUP(TheValueYouNeed, RangeOfSearch, No_index_col, CloseValue)
If IsError(VLOOKUP) Then VLOOKUP = 0
Exit Function
VLookUpError:
VLOOKUP = 0
End Function
I am not the creator of the function but I don't remember where I have found it (thanks anyway)
And then use it nearly as if you were in excel :
Sub lookup_using_function()
Dim lastrow_arr1, lastrow_arr2, i As Long
Dim looked_item As Variant
Dim search_table As Range
Dim col_num As Single
Dim bool As Boolean
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks("Your_File.xlsm")
Set ws = wb.Worksheets("Your_Sheet")
lastrow_arr1 = Range(ws.Cells(1, 1), ws.Cells(1, 1).End(xlDown)).Rows.Count
lastrow_arr2 = Range(ws.Cells(1, 5), ws.Cells(1, 5).End(xlDown)).Rows.Count
Set search_table = ws.Range("A:B")
col_num = 2
bool = False
For i = 2 To lastrow_arr2
looked_item = ws.Cells(i, 5)
ws.Cells(i, 6) = VLOOKUP(looked_item, search_table, col_num, bool)
Next i
Then I usually insert a form, right click on it to assign a macro.
On click the macro assigned is executed.
Edit following your comment:
Cells() works with coordinates.
For example ws.Cells(5,4) stands for cell 5th row of 4th column in the worksheet called ws.
So If your table starts on line 6 and column 3:
'Indicate which data to set up in the arrays (i+5 instead of i)
For i = LBound(arr1) To UBound(arr1)
arr1(i, 1) = ws.Cells(i+5, 3)
arr1(i, 2) = ws.Cells(i+5, 4)
Next i
LBound and Ubound are useful in order to set for loop for an entire array.
To loop through rows:
For i=LBound(arr1) to UBound(arr1)
Next i
To loop through columns you provide the additional argument 2 (default is 1)
For i=LBound(arr1, 2) to UBound(arr1, 2)
Next i
If your table have various columns you may have to loop also through columns to specify which data you want:
For i=LBound(arr1) to UBound(arr1)
For j=LBound(arr1, 2) to UBound(arr1, 2)
arr1(i, j) = ws.Cells(i+5, j+2)
Next j
Next i
I'm trying to group a number from E column starting with 1, the result should be like as below:
Column
E I
1 1-52
. 54-56
. 58-59
.
52
54
55
56
58
59
And I start to write like this:
Sub Group_Numbers()
Dim a As Variant, b As Variant
Dim i As Long, k As Long
Range("I1") = Range("E1")
k = 1
a = Range("E1", Range("E" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 2 To UBound(a)
If a(i, 1) <> Val(a(i - 1, 1)) + 1 Then
k = k + 1
b(k, 1) = a(i, 1)
Else
b(k, 1) = Split(b(k, 1), "-")(0) & -a(i, 1)
End If
Next i
Range("I2").Resize(l).Value = b
End Sub
However, it prompts an error 9 subscript out of range. Hope to get help right here.
Thanks a lot!
I would do the following
Option Explicit
Public Sub Example()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Dim Data() As Variant ' read input data into array
Data = ws.Range("E1", "E" & LastRow).Value2
Dim OutData() As Variant ' define output array
ReDim OutData(1 To UBound(Data, 1), 1 To 1) As Variant
Dim iOut As Long
iOut = 1
Dim StartVal As Long
StartVal = Data(1, 1) ' initialize start value of a group
Dim iRow As Long
For iRow = 2 To UBound(Data, 1) ' loop through values
' check if value is previous value +1
If Data(iRow, 1) <> Data(iRow - 1, 1) + 1 Then
' if not write output from StartVal to previos value
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
iOut = iOut + 1
' and set curent value as new group start
StartVal = Data(iRow, 1)
End If
Next iRow
' close last group
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
' write array back to cells
ws.Range("I1").Resize(RowSize:=iOut).NumberFormat = "#" 'format cells as text so `1-2` does not get converted into date.
ws.Range("I1").Resize(RowSize:=iOut).Value2 = OutData
End Sub
Alternative via Excel's Filter() function (vers. MS 365)
Disposing of the new dynamic array features you can profit from a worksheet-related formula evaluation via a tabular filter upon the data range rows compared with the same range shifted by 1 resulting in an array of endRows numbers. This is the base for a results array which joins start and end values.
The following code allows to define a flexible source range, as the evaluation takes care of the actual start row in the indicated data column.
Example call //edited responding to comment
Sub Grouping()
'0) get data
Dim src As Range
Set src = Sheet1.Range("E1:E59") ' change to your needs
Dim data As Variant
If src.Rows.Count > 1 Then ' is the usual case
data = src.Value2 ' get 2-dim datafield array
Else ' a one liner is the exception
ReDim data(1 To 1, 1 To 1) ' create 2-dim by ReDim
data(1, 1) = Application.Index(src, 1, 1)
End If
'1a)prepare formula evaluation of endRows
Dim EndPattern As String
EndPattern = "=LET(data,$,FILTER(ROW(OFFSET(data,1,0))-" & src.Row & ",ABS(OFFSET(data,1,0)-data)>1))"
EndPattern = Replace(EndPattern, "$", src.Address(False, False))
'1b)evaluate formula
Dim endRows: endRows = src.Parent.Evaluate(EndPattern)
'~~~~~~~~~~~~~~
'2) get results
'~~~~~~~~~~~~~~
Dim results: results = getResults(data, endRows) '<< Help function getResults
'3) write to any target
With Sheet1.Range("I1")
.Resize(UBound(results), 1) = results
End With
End Sub
Help function getResults() //added responding to comment
The usual result of an evaluation is a 1-based 2-dim array with two exceptions code has to provide for:
a) non-findings (which would result only in a returned error value),
b) only a single return value (which is a 1-dim array).
Not enough with these exceptions, the tricky comparison of identical endRows blocks - being shifted by 1 row - makes it necessary to check for the actual last row number if not comprised in endRows. - Imo this might have been the commented issue by #TecLao.
Function getResults(ByRef data, ByRef endRows)
'Purpose: combine value ranges
Dim results As Variant
Dim n As Long: n = UBound(data)
'a) no end row returned by shift-formula evaluation
If IsError(endRows) Then ReDim endRows(1 To 1): endRows(1) = n
'b) one end row found
If Application.WorksheetFunction.CountA(endRows) = 1 Then
ReDim results(1 To IIf(endRows(1) < n, 2, 1), 1 To 1)
'write results
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1), 1)
If UBound(results) = 2 Then
results(2, 1) = _
"'" & data(endRows(1) + 1, 1) & _
"-" & _
data(n, 1)
End If
'c) several end rows found
Else
Dim increment As Long
If endRows(UBound(endRows), 1) < n Then increment = 1
'write results
ReDim results(1 To UBound(endRows) + increment, 1 To 1)
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1, 1), 1)
Dim i As Long
For i = 2 To UBound(endRows)
results(i, 1) = _
"'" & _
data(endRows(i - 1, 1) + 1, 1) & _
"-" & _
data(endRows(i, 1), 1)
Next
If increment Then
results(i, 1) = "'" & data(endRows(i - 1, 1) + 1, 1) & "-" & data(n, 1)
End If
End If
'function return
getResults = results
End Function
I am trying to use a loop with vba to sum values from one worksheet to another. I am struggling with writing my code to match values from Sheet 4 and if the value matches then sum the categories from Sheet 1, if not then skip to the next office. I would also like to exclude certain categories from being included in the SUM loop for example, exclude "Book". Currently my macro is writing to Sheet3. Here is my code:
Option Explicit
Sub test()
Dim a, i As Long, ii As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
a = Sheets("sheet1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dic.Exists(a(i, 1)) Then dic(a(i, 2)) = dic.Count + 2
If Not .Exists(a(i, 1)) Then
Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(i, 2)) = .Item(a(i, 1))(a(i, 2)) + a(i, 3)
Next
ReDim a(1 To .Count + 1, 1 To dic.Count + 1)
a(1, 1) = Sheets("sheet1").[a1]
For i = 0 To dic.Count - 1
a(1, i + 2) = dic.Keys()(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .Keys()(i)
For ii = 2 To UBound(a, 2)
a(i + 2, ii) = .items()(i)(a(1, ii)) + 0
Next
Next
End With
With Sheets("sheet3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.EntireColumn.ClearContents
Sheets("sheet1").[a1].Copy .Rows(1)
.Value = a: .Columns.AutoFit: .Parent.Activate
End With
End Sub
This is how the data looks
and this is the output that is desired
In this example, we will use arrays to achieve what you want. I have commented the code so that you shall not have a problem understanding it. However if you still do then simply ask :)
Input
Output
Logic
Find last row and last column of input sheet
Store in an array
Get unique names from Column A and Row 1
Define output array
Compare array to store sum
Create new sheet and output to that sheet
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim tempArray As Variant, OutputAr() As Variant
Dim officeCol As New Collection
Dim productCol As New Collection
Dim itm As Variant
Dim lrow As Long, lcol As Long, totalsum As Long
Dim i As Long, j As Long, k As Long
'~~> Input sheet
Set ws = Sheet1
With ws
'~~> Get Last Row and last column
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Store it in a temp array
tempArray = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
'~~> Create a unique collection using On error resume next
On Error Resume Next
For i = LBound(tempArray) To UBound(tempArray)
officeCol.Add tempArray(i, 1), CStr(tempArray(i, 1))
productCol.Add tempArray(i, 2), CStr(tempArray(i, 2))
Next i
On Error GoTo 0
End With
'~~> Define you new array which will hold the desired output
ReDim OutputAr(1 To officeCol.Count + 1, 1 To productCol.Count + 1)
'~~> Store the rows and columns in the array
i = 2
For Each itm In officeCol
OutputAr(i, 1) = itm
i = i + 1
Next itm
i = 2
For Each itm In productCol
OutputAr(1, i) = itm
i = i + 1
Next itm
'~~> Calculate sum by comparing the arrays
For i = 2 To officeCol.Count + 1
For j = 2 To productCol.Count + 1
totalsum = 0
For k = LBound(tempArray) To UBound(tempArray)
If OutputAr(i, 1) = tempArray(k, 1) And _
OutputAr(1, j) = tempArray(k, 2) Then
totalsum = totalsum + tempArray(k, 3)
End If
Next k
OutputAr(i, j) = totalsum
Next j
Next i
'~~> Create a new sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Outout the array
wsNew.Range("A1").Resize(officeCol.Count + 1, productCol.Count + 1).Value = OutputAr
End Sub
This is the kind of transformation is what I am trying to perform.
For illustration I made this as table. Basically the first three columns should repeat for however many colors are available.
I searched for similar questions but could not find when I want multiple columns to repeat.
I found this code online
Sub createData()
Dim dSht As Worksheet
Dim sSht As Worksheet
Dim colCount As Long
Dim endRow As Long
Dim endRow2 As Long
Set dSht = Sheets("Sheet1") 'Where the data sits
Set sSht = Sheets("Sheet2") 'Where the transposed data goes
sSht.Range("A2:C60000").ClearContents
colCount = dSht.Range("A1").End(xlToRight).Column
'// loops through all the columns extracting data where "Thank" isn't blank
For i = 2 To colCount Step 2
endRow = dSht.Cells(1, i).End(xlDown).Row
For j = 2 To endRow
If dSht.Cells(j, i) <> "" Then
endRow2 = sSht.Range("A50000").End(xlUp).Row + 1
sSht.Range("A" & endRow2) = dSht.Range("A" & j)
sSht.Range("B" & endRow2) = dSht.Cells(j, i)
sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1)
End If
Next j
Next i
End Sub
I tried changing step 2 to 1 and j to start from 4.
Another example with two varied sets:
Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the columns to be unpivoted)
Test sub:
Sub Tester()
Dim p
'get the unpivoted data as a 2-D array
p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
3, False, False)
With Sheets("Sheet1").Range("H1")
.CurrentRegion.ClearContents
.Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
End With
'EDIT: alternative (slower) method to populate the sheet
' from the pivoted dataset. Might need to use this
' if you have a large amount of data
'Dim r As Long, c As Long
'For r = 1 To Ubound(p, 1)
'For c = 1 To Ubound(p, 2)
' Sheets("Sheet2").Cells(r, c).Value = p(r, c)
'Next c
'Next r
End Sub
UnPivot function - should not need any modifications:
Function UnPivotData(rngSrc As Range, fixedCols As Long, _
Optional AddCategoryColumn As Boolean = True, _
Optional IncludeBlanks As Boolean = True)
Dim nR As Long, nC As Long, data, dOut()
Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
Dim outRows As Long, outCols As Long
data = rngSrc.Value 'get the whole table as a 2-D array
nR = UBound(data, 1) 'how many rows
nC = UBound(data, 2) 'how many cols
'calculate the size of the final unpivoted table
outRows = nR * (nC - fixedCols)
outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
'resize the output array
ReDim dOut(1 To outRows, 1 To outCols)
'populate the header row
For c = 1 To fixedCols
dOut(1, c) = data(1, c)
Next c
If AddCategoryColumn Then
dOut(1, fixedCols + 1) = "Category"
dOut(1, fixedCols + 2) = "Value"
Else
dOut(1, fixedCols + 1) = "Value"
End If
'populate the data
rOut = 1
For r = 2 To nR
For cat = fixedCols + 1 To nC
If IncludeBlanks Or Len(data(r, cat)) > 0 Then
rOut = rOut + 1
'Fixed columns...
For c = 1 To fixedCols
dOut(rOut, c) = data(r, c)
Next c
'populate unpivoted values
If AddCategoryColumn Then
dOut(rOut, fixedCols + 1) = data(1, cat)
dOut(rOut, fixedCols + 2) = data(r, cat)
Else
dOut(rOut, fixedCols + 1) = data(r, cat)
End If
End If
Next cat
Next r
UnPivotData = dOut
End Function
Here is one way (fastest?) using arrays. This approach is better that the linked question as it doesn't read and write to/from range objects in a loop. I have commented the code so you shouldn't have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim ThisAr As Variant, ThatAr As Variant
Dim Lrow As Long, Col As Long
Dim i As Long, k As Long
Set wsThis = Sheet1: Set wsThat = Sheet2
With wsThis
'~~> Find Last Row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find total value in D,E,F so that we can define output array
Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))
'~~> Store the values from the range in an array
ThisAr = .Range("A2:F" & Lrow).Value
'~~> Define your new array
ReDim ThatAr(1 To Col, 1 To 4)
'~~> Loop through the array and store values in new array
For i = LBound(ThisAr) To UBound(ThisAr)
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
'~~> Check for Color 1
If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)
'~~> Check for Color 2
If ThisAr(i, 5) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 5)
End If
'~~> Check for Color 3
If ThisAr(i, 6) <> "" Then
k = k + 1
ThatAr(k, 1) = ThisAr(i, 1)
ThatAr(k, 2) = ThisAr(i, 2)
ThatAr(k, 3) = ThisAr(i, 3)
ThatAr(k, 4) = ThisAr(i, 6)
End If
Next i
End With
'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value
'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub
SHEET1
SHEET2
The addition of the LET function allows for this non-VBA solution.
=LET(data,B3:F6,
dataRows,ROWS(data),
dataCols,COLUMNS(data),
rowHeaders,OFFSET(data,0,-1,dataRows,1),
colHeaders,OFFSET(data,-1,0,1,dataCols),
dataIndex,SEQUENCE(dataRows*dataCols),
rowIndex,MOD(dataIndex-1,dataRows)+1,
colIndex,INT((dataIndex-1)/dataRows)+1,
FILTER(CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)), index(data,rowIndex,colIndex)<>""))
Below is a custom function I wrote for such things (demo video I posted on YouTube). A few differences from other answers:
The custom function allows for more than one axis in columns. As shown below, the column axis has Currency and Time.
Row axis does not need to be directly next to the data range.
One can specify the entire row as the column axis or the entire column to specify the row axis. See formula used as example below.
So with this data set:
And entering this as the formula:
=unPivotData(D4:G7,2:3,B:C)
an output of this:
Function unPivotData(theDataRange As Range, theColumnRange As Range, theRowRange As Range, _
Optional skipZerosAsTrue As Boolean, Optional includeBlanksAsTrue As Boolean)
'Set effecient range
Dim cleanedDataRange As Range
Set cleanedDataRange = Intersect(theDataRange, theDataRange.Worksheet.UsedRange)
'tests Data ranges
With cleanedDataRange
'Use intersect address to account for users selecting full row or column
If .EntireColumn.Address <> Intersect(.EntireColumn, theColumnRange).EntireColumn.Address Then
unPivotData = "datarange missing Column Ranges"
ElseIf .EntireRow.Address <> Intersect(.EntireRow, theRowRange).EntireRow.Address Then
unPivotData = "datarange missing row Ranges"
ElseIf Not Intersect(cleanedDataRange, theColumnRange) Is Nothing Then
unPivotData = "datarange may not intersect column range. " & Intersect(cleanedDataRange, theColumnRange).Address
ElseIf Not Intersect(cleanedDataRange, theRowRange) Is Nothing Then
unPivotData = "datarange may not intersect row range. " & Intersect(cleanedDataRange, theRowRange).Address
End If
'exits if errors were found
If Len(unPivotData) > 0 Then Exit Function
Dim dimCount As Long
dimCount = theColumnRange.Rows.Count + theRowRange.Columns.Count
Dim aCell As Range, i As Long, g As Long
ReDim newdata(dimCount, i)
End With
'loops through data ranges
For Each aCell In cleanedDataRange.Cells
With aCell
If .Value2 = "" And Not (includeBlanksAsTrue) Then
'skip
ElseIf .Value2 = 0 And skipZerosAsTrue Then
'skip
Else
ReDim Preserve newdata(dimCount, i)
g = 0
'gets DimensionMembers members
For Each gcell In Union(Intersect(.EntireColumn, theColumnRange), _
Intersect(.EntireRow, theRowRange)).Cells
newdata(g, i) = IIf(gcell.Value2 = "", "", gcell.Value)
g = g + 1
Next gcell
newdata(g, i) = IIf(.Value2 = "", "", .Value)
i = i + 1
End If
End With
Next aCell
unPivotData = WorksheetFunction.Transpose(newdata)
End Function
Hope I'm in the right place.
I have a spreadsheet which is around 8000 rows long and I need to paste a column of data from J to E. Problem is that E already has some data in it which I want to retain. The data in J is also partial and needs to be pasted into blank cells in E.
The result would be a complete list of data in E which is a combination of E's original data and the pasted data from J.
Thanks
Place the following routine in a standard code module and run it with the worksheet active:
Public Sub excelhero()
Dim e&, j&, i&, v, vE, vJ
With ActiveSheet
e = .Cells(.Rows.Count, "e").End(xlUp).Row
j = .Cells(.Rows.Count, "j").End(xlUp).Row
End With
ReDim vE(1 To e, 1 To 1)
ReDim vJ(1 To j, 1 To 1)
ReDim v(1 To Application.max(e, j), 1 To 1)
vE = [e1].Resize(UBound(vE))
vJ = [j1].Resize(UBound(vJ))
For i = 1 To UBound(vE)
v(i, 1) = vE(i, 1)
Next
For i = 1 To UBound(vJ)
If Len(vJ(i, 1)) Then
v(i, 1) = vJ(i, 1)
End If
Next
[e1].Resize(UBound(v)) = v
End Sub
The above will work for your specific columns. Here is a more generic version that will work for merging any two columns. It will also work for your scenario because columns E and J are set to be the columns it works with at the top. COLA_A values will not be overwritten, only COL_A empty cells will be.
Public Sub MergeColumns()
Const COL_A = "E" '<-- COL_A has priority.
Const COL_B = "J"
Dim cola&, colb&, i&, v, vA, vB
With ActiveSheet
cola = .Cells(.Rows.Count, COL_A).End(xlUp).Row
colb = .Cells(.Rows.Count, COL_B).End(xlUp).Row
End With
ReDim vA(1 To cola, 1 To 1)
ReDim vB(1 To colb, 1 To 1)
ReDim v(1 To Application.max(cola, colb), 1 To 1)
vA = Range(COL_A & 1).Resize(UBound(vA))
vB = Range(COL_B & 1).Resize(UBound(vB))
For i = 1 To UBound(vA)
v(i, 1) = vA(i, 1)
Next
For i = 1 To UBound(vB)
If Len(vB(i, 1)) Then
v(i, 1) = vB(i, 1)
End If
Next
Range(COL_A & 1).Resize(UBound(v)) = v
End Sub