Related
I'm trying to compare two columns (A and B) containing company names, find any names that are an exact match, and list them in column C. With the code below I don't get an error but nothing happens. If someone could point me in the right direction it would be appreciated.
Sub match()
Dim LastRow As Integer
Dim i As Integer
LastRow = Range("B" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
Set Row2Name = Sheets("Sheet1").Cells(i, 2)
Set Row1Name = Sheets("Sheet1").Cells(i, 1)
Set MatchName = Sheets("Sheet1").Cells(i, 1)
If Cells(i, 2) = Row1Name Then
Row2Name.Copy
MatchName.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next i
End Sub
Here is a tidied version with correctly using column C i.e.
Set MatchName = Sheets("Sheet1").Cells(i, 3) if column C.
Code:
Option Explicit
Public Sub matching()
Dim LastRow As Long, i As Long, Row2Name As Range, Row1Name As Range, MatchName As Range
With Worksheets("Sheet1")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 3 To LastRow
Set Row2Name = .Cells(i, 2)
Set Row1Name = .Cells(i, 1)
Set MatchName = .Cells(i, 3)
If .Cells(i, 2) = Row1Name Then
Row2Name.Copy
MatchName.PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
End Sub
Which is essentially this:
Option Explicit
Public Sub matching()
Dim i As Long
Application.ScreenUpdating = False
With Worksheets("Sheet1")
For i = 3 To .Range("B" & .Rows.Count).End(xlUp).Row
If .Cells(i, 1) = .Cells(i, 2) Then .Cells(i, 3) = .Cells(i, 2)
Next i
End With
Application.ScreenUpdating = True
End Sub
For large numbers of rows you could do this all in memory using an array.
Public Sub matching()
Dim arr(), i As Long
With Worksheets("Sheet1")
.Columns(3).ClearContents
arr = .Range("A3:C" & .Range("B" & .Rows.Count).End(xlUp).Row).Value
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 1) = arr(i, 2) Then arr(i, 3) = arr(i, 2)
Next i
.Cells(3, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Try to process in memory with arrays and avoid loops when faster 'prove existence' methods are available..
Sub matchComps()
Dim i As long, j As long, arrA as variant, arrB as variant, arrC as variant
with workSheets("Sheet1")
arrA = .range(.cells(3, "A"), .cells(.rows.count, "A").end(xlup)).value2
arrb = .range(.cells(3, "B"), .cells(.rows.count, "B").end(xlup)).value2
redim arrc(1 to application.min(ubound(arra, 1) ,ubound(arrb, 1)), 1 to 1)
for i= lbound(arra, 1) to ubound(arra, 1)
if not iserror(application.match(arra(i, 1), arrb, 0)) then
j=j+1
arrc(j,1) = arra(i, 1)
end if
next i
.cells(3, "C").resize(ubound(arrc, 1), ubound(arrc, 2)) = arrc
end with
End Sub
With the code below which I have obtained from https://stackoverflow.com/a/41558057/7282657 I can split, copy and paste data for the "Setup" rows and the odd Microphone rows. What I am now having trouble with is splitting and copying the data for all Microphone rows and allocating them to correct "Room".
To my understanding the reason why not all of the Microphone data is being split is because of this line of code mic = .Range("B" & i).Offset(2, 0).Value
Is there an alternative to using Offset so I can split all the Microphone rows?
Here is a picture of my input data
Here is what I would like the output to look like
I have tried to modify the code so that an IF statement checks what "Room" it is and then splits and copies the data for that particular Room into a new sheet until it comes to the next Room where the process will be repeated.
Sub Sample()
Dim myArr, setup, mic
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, col As Long
Dim arrHeaders, arrHeadersMic
Set ws = ThisWorkbook.Sheets("Sheet1") '~~> Set this to the relevant worksheet
With ThisWorkbook
' Set wsOutput = .Sheets.Add(after:=.Sheets(.Sheets.Count)) '~~> Add a new worksheet for output
Set wsOutput = ThisWorkbook.Sheets("Sheet2")
End With
rw = 3 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manuf", "Model", "ModelNum")
j = 1
For r = 1 To 1000 ' Do 1000 rows
Select Case Left(Trim(ws.Cells(r, 1).Value), 1000)
Case "Room 1"
ws.Rows(r).Copy wsOutput.Rows(j)
With ws
Lrow = .Range("B" & .Rows.Count).End(xlUp).Row '~~> get the last row
For i = 1 To Lrow
If .Cells(i, 1).Value = "Setup" Then
setup = .Range("B" & i).Value
mic = .Range("B" & i).Offset(2, 0).Value
If Len(setup) > 0 Then
myArr = SetupToArray(setup)
wsOutput.Cells(rw, 1).Value = "Setup"
wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders 'add the headers
wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(myArr) + 1) 'fill headers across
wsOutput.Cells(rw + 1, 3).Resize(1, UBound(myArr) + 1).Value = myArr 'populate the array
wsOutput.Cells(rw + 3, 1).Value = "Microphone"
wsOutput.Cells(rw + 3, 3).Resize(1, UBound(arrHeadersMic) + 1).Value = arrHeadersMic
If Len(mic) > 0 Then
myArr = MicToArray(mic)
wsOutput.Cells(rw + 4, 3).Resize(1, UBound(myArr) + 1).Value = myArr
End If
rw = rw + 6
End If
End If
Next i
End With
End Select
'j = j + 8
Next r
End Sub
Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
SetupToArray = TrimSpace(Split(v, ","))
End Function
Function MicToArray(w)
w = Replace(w, " x ", " ")
MicToArray = TrimSpace(Split(w, " "))
End Function
Function TrimSpace(arr)
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = Trim(arr(i))
Next i
TrimSpace = arr
End Function
Here is also a link to a sample document of my data:
https://drive.google.com/file/d/0B07kTPaMi6JndDVJS01HbVVoTDg/view
I Thank you in advance for your help and apologize for the long question!
This seemed to work quite well
Sub BuildReport()
Dim myArr, setup, mic
Dim ws As Worksheet, wsOutput As Worksheet
Dim Lrow As Long, i As Long, j As Long, rw As Long, r As Long
Dim m As Long, MicRow As Long, SetupRow As Long
Dim arrHeaders, arrHeadersMic
Set ws = ThisWorkbook.Sheets("Sheet1")
With ThisWorkbook
Set wsOutput = ThisWorkbook.Sheets("Sheet2")
End With
rw = 2 '<< output starts on this row
arrHeaders = Array("Speaker", "Tables", "People")
arrHeadersMic = Array("Number", "Manuf", "Model", "ModelNum")
Lrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row '~~> get the last row
For i = 1 To Lrow
If Left(ws.Cells(i, 1).Value, 4) = "Room" Then
' Room Info is in Row i. Setup is in Row (i+1).
wsOutput.Cells(rw, 1).Resize(1, 2).Value = Array(ws.Cells(i, 1).Value, Cells(i, 2).Value)
rw = rw + 1
SetupRow = i + 1
setup = ws.Cells(SetupRow, 2).Value
If Len(setup) > 0 Then
myArr = SetupToArray(setup)
wsOutput.Cells(rw, 1).Value = "Setup"
wsOutput.Cells(rw, 3).Resize(1, 3).Value = arrHeaders 'add the headers
wsOutput.Cells(rw, 3).Resize(1, 3).AutoFill _
Destination:=wsOutput.Cells(rw, 3).Resize(1, UBound(myArr) + 1) 'fill headers across
wsOutput.Cells(rw + 1, 3).Resize(1, UBound(myArr) + 1).Value = myArr 'populate the array
rw = rw + 3
End If
' An unknown number of Microphones start in Row (i+2)
MicRow = SetupRow + 1
For m = MicRow To (MicRow + 10)
If ws.Cells(m, 1).Value = "Microphone" Then
mic = ws.Cells(m, 2).Value
If Len(mic) > 0 Then
wsOutput.Cells(rw, 1).Value = "Microphone"
wsOutput.Cells(rw, 3).Resize(1, UBound(arrHeadersMic) + 1).Value = arrHeadersMic
myArr = MicToArray(mic)
wsOutput.Cells(rw + 1, 3).Resize(1, UBound(myArr) + 1).Value = myArr
rw = rw + 3
End If
Else
Exit For ' reached end of Microphones
End If
Next m
End If
Next i
End Sub
Function SetupToArray(v)
Dim MYAr, i
v = Replace(v, ":", ",")
v = Replace(v, " x ", ",")
SetupToArray = TrimSpace(Split(v, ","))
End Function
Function MicToArray(w)
w = Replace(w, " x ", " ")
MicToArray = TrimSpace(Split(w, " "))
End Function
Function TrimSpace(arr)
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = Trim(arr(i))
Next i
TrimSpace = arr
End Function
I want to be able to combine the rows for which the value in the first column matches, so that the values of non-blank cells are consolidated into one row. E.g.:
Mary Smith, A, [blank cell]
Mary Smith, [blank cell], B
-->
Mary Smith A B
I've tried to use the code below:
Dim RowNum As Long, LastRow As Long
Application.ScreenUpdating = False
RowNum = 4
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Range("A4", Cells(LastRow, 13)).Select
For Each Row In Selection
With Cells
If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then
Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 1)
Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 2)
Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 3)
Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 4)
Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 5)
Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 6)
Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 7)
Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 8)
Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 9)
Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 10)
Cells(RowNum + 1, 11).Copy Destination:=Cells(RowNum, 11)
Cells(RowNum + 1, 12).Copy Destination:=Cells(RowNum, 12)
Cells(RowNum + 1, 13).Copy Destination:=Cells(RowNum, 13)
Rows(RowNum + 1).EntireRow.Delete
End If
End With
RowNum = RowNum + 1
Next Row
Application.ScreenUpdating = True
'
End Sub
This does a fine job of consolidating the data so that there are only unique values in the first column, HOWEVER, when the row is copied up, the values of blank cells copy over populated cells, which NOT what I want. So for instance, running this macro on the above data would yield:
Mary Smith, A, [blank cell]
Mary Smith, [blank cell], B
-->
Mary Smith, A, [blank cell]
Any insight into how I might modify the above code (or use something more elegant) would be appreciated!!
This will do it very quickly:
Sub foo()
Dim ws As Worksheet
Dim lstrow As Long
Set ws = Sheets("Sheet1") ' Change to your sheet
With ws
lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B4:M" & lstrow)
.Offset(, 26).FormulaR1C1 = "=IFERROR(INDEX(R4C[-26]:R" & lstrow & "C[-26],MATCH(1,INDEX((R4C1:R" & lstrow & "C1 = RC1)*(R4C[-26]:R" & lstrow & "C[-26] <>""""),),0)),"""")"
ws.Calculate
.Value = .Offset(, 26).Value
.Offset(, 26).ClearContents
End With
With .Range("A4:M" & lstrow)
.Value = .Value
.RemoveDuplicates 1, xlGuess
End With
End With
End Sub
It basically uses the formula: =INDEX(B$4:B$4,MATCH(1,INDEX(($A$4:$A$4 = $A4)*(B$4:B$4 <>""),),0)) To find all the values. Puts those formulas in blank columns and then copies the data back and removes the duplicates.
This will do all 13 columns at once.
It also does not care how many times the value in Column A is repeated. There could be 4 Mary Smiths in that column. It will grab the first value in each column and use that.
Before:
After:
Try the below code
Sub test()
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To LastRow
If ((Range("A" & i).Value = Range("A" & i + 1).Value) And (Range("B" & i).Value <> Range("B" & i + 1).Value) And ((Range("B" & i).Value = "") Or (Range("B" & i + 1).Value = "")) And (Range("C" & i).Value <> Range("C" & i + 1).Value) And ((Range("C" & i).Value = "") Or (Range("C" & i + 1).Value = ""))) Then
If Range("B" & i).Value = "" Then
Range("B" & i).Value = Range("B" & i + 1).Value
ElseIf Range("B" & i + 1).Value = "" Then
Range("B" & i + 1).Value = Range("B" & i).Value
End If
If Range("C" & i).Value = "" Then
Range("C" & i).Value = Range("C" & i + 1).Value
ElseIf Range("C" & i + 1).Value = "" Then
Range("C" & i + 1).Value = Range("C" & i).Value
End If
End If
Range("B" & i).EntireRow.Delete Shift:=(xlUp)
LastRow = LastRow - 1
Next i
End Sub
Here is another approach.
Create a Personnel object. Each Personnel object can have multiple attributes (the non blank column entries in your original table).
By using the Key property of the collection object, and using the Name (column1 data) as the key, we can detect duplicates without having to sort the original data. And the number of attributes for each name is limited only by the size of the worksheet.
Other information is in the comments.
Insert a class object and rename it cPersonnel
Below is the code for the Class and Regular modules
Class Module
Option Explicit
Private pName As String
Private pAttrib As String
Private pAttribs As Collection
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Public Property Get Attrib() As String
Attrib = pAttrib
End Property
Public Property Let Attrib(Value As String)
pAttrib = Value
End Property
Public Property Get AttribS() As Collection
Set AttribS = pAttribs
End Property
Public Function ADDAttribS(Value As String)
pAttribs.Add Value
End Function
Private Sub Class_Initialize()
Set pAttribs = New Collection
End Sub
Regular Module
Option Explicit
Sub PersonnelAttribs()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cP As cPersonnel, colP As Collection
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long
'Set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With
'Read source data into array
With wsSrc
vSrc = Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'create and collect the Personnel objects
'Source data does not need to be sorted
Set colP = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
If Trim(vSrc(I, 1)) <> "" Then
Set cP = New cPersonnel
With cP
.Name = vSrc(I, 1)
For J = 2 To UBound(vSrc, 2)
If Trim(vSrc(I, J)) <> "" Then
.Attrib = Trim(vSrc(I, J))
.ADDAttribS .Attrib
End If
Next J
colP.Add cP, .Name
Select Case Err.Number
Case 457 'duplicate name
Err.Clear
For J = 1 To .AttribS.Count
colP(.Name).ADDAttribS .AttribS(J)
Next J
Case Is <> 0
Debug.Print Err.Number, Err.Description
Stop
End Select
End With
End If
Next I
On Error GoTo 0
'Create results array
'Number of columns
For I = 1 To colP.Count
With colP(I)
J = IIf(J > .AttribS.Count, J, .AttribS.Count)
End With
Next I
ReDim vRes(0 To colP.Count, 0 To J)
'Headers
vRes(0, 0) = "Name"
For J = 1 To UBound(vRes, 2)
vRes(0, J) = "Attrib " & J
Next J
'Populate data
For I = 1 To colP.Count
With colP(I)
vRes(I, 0) = .Name
For J = 1 To .AttribS.Count
vRes(I, J) = .AttribS(J)
Next J
End With
Next I
'Clear old data and write new
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Original Data
Results after Macro
How can I generate the Excel as in the image below via a macro?
Briefly I would like to make:
numbers between a1 and b1 print to d column;
numbers between a2 and b2 print to e column;
numbers between a3 and b3 print to f column.
Columns A and B have thousands of values.
As an alternative, here is a formula solution:
=IF(ROW(D1)>INDEX($A:$B,COLUMN(D1)-COLUMN($C1),2)-INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+1,"",INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+ROW(D1)-1)
Though I realize that a formula solution may not be feasible based on this statement:
Columns A and B have thousands of values.
EDIT: Pure array VBA solution:
Sub tgr()
Dim ws As Worksheet
Dim rData As Range
Dim aData As Variant
Dim aResults() As Variant
Dim lMaxDiff As Long
Dim i As Long, j As Long
Dim rIndex As Long, cIndex As Long
Set ws = ActiveWorkbook.ActiveSheet
Set rData = ws.Range("A1", ws.Cells(Rows.Count, "B").End(xlUp))
lMaxDiff = Evaluate("MAX(" & rData.Columns(2).Address(external:=True) & "-" & rData.Columns(1).Address(external:=True) & ")") + 1
aData = rData.Value2
ReDim aResults(1 To lMaxDiff, 1 To rData.Rows.Count)
For i = LBound(aData, 1) To UBound(aData, 1)
If IsNumeric(aData(i, 1)) And IsNumeric(aData(i, 2)) Then
rIndex = 0
cIndex = cIndex + 1
For j = Int(aData(i, 1)) To Int(aData(i, 2))
rIndex = rIndex + 1
aResults(rIndex, cIndex) = j
Next j
End If
Next i
ws.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
Only because I like puzzles:
Sub u5758()
Dim x As Long
Dim i As Long
Dim oArr() As Variant
Dim arr() As Long
Dim rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
x = 4
With ws
oArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).value
For j = LBound(oArr, 1) To UBound(oArr, 1)
ReDim arr(oArr(j, 1) To oArr(j, 2))
For i = LBound(arr) To UBound(arr)
arr(i) = i
Next i
.Cells(1, x).Resize(UBound(arr) - LBound(arr) + 1).value = Application.Transpose(arr)
x = x + 1
Next j
End With
Application.ScreenUpdating = True
End Sub
I like puzzles too.
Sub from_here_to_there()
Dim rw As Long
With Worksheets("Sheet5") '<~~ set this worksheet properly!
For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(.Cells(rw, 1)) And IsNumeric(.Cells(rw, 2)) Then
With .Columns(Application.Max(4, .Cells(1, Columns.Count).End(xlToLeft).Column + 1))
.Cells(1, 1) = .Parent.Cells(rw, 1).Value2
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=.Parent.Cells(rw, 2).Value2
End With
End If
Next rw
End With
End Sub
You could use this:
Sub test()
Dim Lastrow As Long
Dim j As Double, i As Double, r As Double
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Change the name of your sheet
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
j = 4 ' Column D
With ws
For i = 1 To Lastrow ' Start the loop at A1 until the last row in column A
.Cells(1, j) = .Cells(i, 1).Value
r = 1
Do
.Cells(r + 1, j) = .Cells(r, j) + 1
r = r + 1
Loop Until .Cells(r, j) = .Cells(i, 2).Value
j = j + 1
Next i
End With
End Sub
Here's another quick one just for fun:
Sub transposeNfill()
Dim lastRow&, i&, xStart$, xEnd$, xMid$
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
xStart = Cells(i, 1)
xEnd = Cells(i, 2)
xMid = xEnd - xStart
Cells(1, i + 3).Value = xStart
Cells(1 + xMid, i + 3) = xEnd
Range(Cells(2, i + 3), Cells(xMid, i + 3)).FormulaR1C1 = "=r[-1]c+1"
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Next i
End Sub
I tried to write comparison in Excel macro for my work. Somehow, it is working not in the way I wanted the output. What I want is to compare the two columns and show the differences between them. If empty field on one column, the program should skip a line. Here is my code:
Sub run_compare_main()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim last_row As Integer
Dim input_array As Variant
Dim output_aray() As String
Dim a_counter As Integer
Dim b_counter As Integer
last_row = get_last_row("INPUT", "A")
ReDim output_array(1 To (last_row * 2), 1 To 5) '(last_row * 2)
input_array = Range("A7:D7" & (last_row * 2)).Value2
a_counter = 1
b_counter = 1
For i = 1 To (last_row * 2)
If input_array(a_counter, 1) = input_array(b_counter, 3) Then
output_array(i, 1) = input_array(a_counter, 1)
output_array(i, 2) = input_array(a_counter, 2)
output_array(i, 3) = input_array(b_counter, 3)
output_array(i, 4) = input_array(b_counter, 4)
a_counter = a_counter + 1
b_counter = b_counter + 1
ElseIf input_array(a_counter, 1) = input_array(a_counter - 1, 1) Then
output_array(i, 1) = input_array(a_counter, 1)
output_array(i, 2) = input_array(a_counter, 2)
a_counter = a_counter + 1
ElseIf input_array(b_counter, 3) = input_array(b_counter - 1, 3) Then
output_array(i, 3) = input_array(b_counter, 3)
output_array(i, 4) = input_array(b_counter, 4)
b_counter = b_counter + 1
End If
'find smaller value
If input_array(a_counter, 1) < input_array(b_counter, 3) Or input_array(b_counter, 1) = "" Then
output_array(i, 1) = input_array(a_counter, 1)
output_array(i, 2) = input_array(a_counter, 2)
a_counter = a_counter + 1
Else
output_array(i, 3) = input_array(b_counter, 3)
output_array(i, 4) = input_array(b_counter, 2)
b_counter = b_counter + 1
End If
If a_counter = last_row - 5 Or b_counter = last_row - 5 Then
Exit For
End If
Next
Call newtab("OUTPUT")
Range("A7").Resize(last_row, 4).Value = output_array
Sheets("INPUT").Range("A5:D6").Copy
Sheets("OUTPUT").Range("A5").Select
ActiveSheet.Paste
Columns("B:B").ColumnWidth = 80
Columns("D:D").ColumnWidth = 80
Dim LastCol As Long
Dim LastRow As Long
LastCol = ActiveSheet.UsedRange.Columns.Count
LastRow = ActiveSheet.UsedRange.Rows.Count
FilePath = "D:\Try\support.txt"
Open FilePath For Output As #2
CellData = ""
For i = 1 To LastRow
For j = 1 To LastCol
CellData = "The Value at location (" & i & "," & j & ") " & Trim(ActiveCell(i, j).Value)
Write #2, CellData
Next j
Next i
Close #2
MsgBox ("Job Done")
End Sub
Sub newtab(sheetname As String)
Application.DisplayAlerts = False
On Error Resume Next
Sheets(sheetname).Delete
Application.DisplayAlerts = True
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Activate
Sheets(Sheets.Count).Name = sheetname
End Sub
Function get_last_row(ByVal sheetname As String, column As String) As Integer
With Sheets(sheetname)
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range(column & "1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
get_last_row = LastRow
End Function
and here my worksample: