how to insert data from textbox to excel using vb.net? - vb.net

I'm stuck here, I want to insert the data from 5 textbox to existing excel file in columns. I found code but its inserting by rows. I have below a code that finds the last non empty row and from that row I want to move to the next row and insert data there, for example last row is A2, I want to insert new data to A3, B3, C3, D3, E3.
I can't get the right loop for this.
Dim lRow As Long = 0
Call OpenExcelFile("C:\Users\PB\Desktop\BookRecords.xlsx", 1)
With xlWorkSheet
If EXL.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A2"), _
LookAt:=Excel.XlLookAt.xlPart, _
LookIn:=Excel.XlFindLookIn.xlFormulas, _
SearchOrder:=Excel.XlSearchOrder.xlByRows, _
SearchDirection:=Excel.XlSearchDirection.xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
lRow += 1
End With
MessageBox.Show("The last row in Sheet1 which has data is " & lRow)
Dim j As Integer
j = 3
For i As Integer = j To 8
xlWorkSheet.Range(xlWorkSheet.Cells(lRow + 1, j).item).Value = txtTitle.Text
xlWorkSheet.Range(xlWorkSheet.Cells(lRow + 1, j).item).Value = txtAuthor.Text
xlWorkSheet.Range(xlWorkSheet.Cells(lRow + 1, j).item).Value = txtEdition.Text
xlWorkSheet.Range(xlWorkSheet.Cells(lRow + 1, j).item).Value = txtPublisher.Text
xlWorkSheet.Range(xlWorkSheet.Cells(lRow + 1, j).item).Value = txtISBN.Text
Next
j += 1
Call SaveAndCloseExcelSub()

Does this help:
Dim j As Integer
j = 3
For i As Integer = j To 8
MsgBox("Cell column: " & ColumnNumberToName(i))
Next
Code to convert numbers to Excel Column Names (A-Z, AA, etc):
Public Shared Function ColumnNumberToName(columnNumber As Int32) As String
Dim dividend As Int32 = columnNumber
Dim columnName As [String] = [String].Empty
Dim modulo As Int32
While dividend > 0
modulo = (dividend - 1) Mod 26
columnName = Convert.ToChar(65 + modulo).ToString() + columnName
dividend = DirectCast(((dividend - modulo) / 26), Int32)
End While
Return columnName
End Function
Public Shared Function ColumnNameToNumber(columnName As [String]) As Int32
If [String].IsNullOrEmpty(columnName) Then
Throw New ArgumentNullException("columnName")
End If
Dim characters As Char() = columnName.ToUpperInvariant().ToCharArray()
Dim sum As Int32 = 0
Dim i As Int32 = 0
While i < characters.Length
sum *= 26
sum += (characters(i) - "A"C + 1)
System.Math.Max(System.Threading.Interlocked.Increment(i),i - 1)
End While
Return sum
End Function

As it is, all your values are being written to the same cell; then you move down a row and do it again. Cells are addressed as (row, column) - so you need to change your code like this:
Dim j As Integer
j = 3
For i As Integer = j To 8
xlWorkSheet.Cells(lRow + i, 1).Value = txtTitle.Text
xlWorkSheet.Cells(lRow + i, 2).Value = txtAuthor.Text
xlWorkSheet.Cells(lRow + i, 3).Value = txtEdition.Text
xlWorkSheet.Cells(lRow + i, 4).Value = txtPublisher.Text
xlWorkSheet.Cells(lRow + i, 5).Value = txtISBN.Text
Next
Not sure if you need to start with i = 3 if you add lRow to it but I'm sure you can work that out.
If you want the order reversed, do this (this example copies only one lot of text... I am beginning to suspect there is no need for the loop)
dim i as Integer
i = 1; ' if you want column A
With xlWorkSheet
.Cells(lRow , i).Value = txtTitle.Text
.Cells(lRow + 1, i).Value = txtAuthor.Text
.Cells(lRow + 2, i).Value = txtEdition.Text
.Cells(lRow + 3, i).value = txtPublisher.Text
.Cells(lRow + 4, i).Value = txtISBN.Text
End With

Related

Excel: Count unique comma-delimited strings in a column with countifs-style criteria from other columns

Hoping for help form an Excel/VBA wizard on this problem. I have a possible vision of what i need, but lack the expertise to pull it off.
Essentially the problem combines the use of a countifs formula (with multiple criteria) along with counting unique strings in a column containing comma-delimited strings like this:
Criteria1 | Criteria2 |Names
A | X |Bob
B | Y |Cam;Bob
A | Y |Dan;Ava
A | Y |Ava;Cam
^In this super-simplified example, it would be like counting unique names where Criteria1 = A & criteria2 = Y. Answer = 3 (Cam, Dan, Ava)
So far, i've been able to find a VBA solution (from here)that counts unique strings in a given column like "names" above, but I don't know how to combine that with countifs-style criteria to only pass certain parts of the names range to that function.
I have created an xlsm spreadsheet that further elaborates on the problem with better sample data, expected results and the partial VBA solution I have so far:
xlsx
edit: I'm using Excel 2013
edit2: uploaded xlsx in addition to xlsm. VBA code i'm currently using is below. Note that I copied this form another source and I don't really understand how the scripting.dictionary stuff works :/
Function cntunq(ByVal rng As Range)
' http://www.mrexcel.com/forum/excel-questions/437952-counting-unique-values-seperate-comma.html
Dim cl As Range, i As Integer
Dim dic1, ar
ar = Split(Replace(Join(Application.Transpose(rng), ";"), vbLf, ""), ";")
Debug.Print Join(ar, ";")
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
For i = 0 To UBound(ar)
dic1(ar(i)) = ""
Next i
cntunq = dic1.Count
End Function
Edit3: The above code just does the counting of unique values in a given range with ;-delimited strings. The part i don't know is how to modify this to take paramArray of conditions
Here it is in a UDF using a dictionary:
Function MyCount(critRng As Range, crit As String, critRng2 As Range, crit2 As String, cntRng As Range, delim As String) As Long
Dim critarr(), critarr2(), cntarr()
Set dict = CreateObject("Scripting.Dictionary")
critarr = critRng.Value
cntarr = cntRng.Value
critarr2 = critRng2.Value
If UBound(critarr, 1) <> UBound(cntarr, 1) Then Exit Function
For i = LBound(critarr, 1) To UBound(critarr, 1)
If critarr(i, 1) = crit And critarr2(i, 1) = crit2 Then
splt = Split(cntarr(i, 1), delim)
For j = LBound(splt) To UBound(splt)
On Error Resume Next
dict.Add splt(j), splt(j)
On Error GoTo 0
Next j
End If
Next i
MyCount = dict.Count
End Function
Put that in a module and you would call it like a formula:
=MyCount($A$2:$A$5,"A",$B$2:$B$5,"Y",$C$2:$C$5,";")
Edit as per Comments
This will allow an Array entry, which will allow many conditions:
Function MyCount2(delim As String, rsltArr()) As Long
Set dict = CreateObject("Scripting.Dictionary")
Dim splt() As String
Dim i&, j&
For i = LBound(rsltArr, 1) To UBound(rsltArr, 1)
If rsltArr(i, 1) <> "False" And rsltArr(i, 1) <> "" Then
splt = Split(rsltArr(i, 1), delim)
For j = LBound(splt) To UBound(splt)
On Error Resume Next
dict.Add splt(j), splt(j)
On Error GoTo 0
Next j
End If
Next i
MyCount2 = dict.Count
End Function
This then is entered as the following array formula:
=MyCount2(";",IF(($A$2:$A$5="A")*($B$2:$B$5="Y"),$C$2:$C$5))
Being an array formula it needs to be confirmed with Ctrl-Shift-Enter when exiting edit mode instead of Enter. If done correctly then Excel will put {} around the formula.
If you want more criteria, then add another Boolean multiply to the existing in the first criterion of the IF() statement. So if you wanted to test if column Z was greater than 0 you would add * ($Z$2:$Z$5>0) after the column B test.
Here is a non array formula that uses ParamArray.
Function MyCount3(cntrng As Range, delim As String, ParamArray t()) As Long
Set dict = CreateObject("Scripting.Dictionary")
Dim cntArr As Variant
cntArr = cntrng.Value
Dim tArr() As Boolean
Dim splt() As String
Dim I&, l&
Dim tpe As String
ReDim tArr(1 To t(0).Rows.Count)
For l = 1 To t(0).Rows.Count
For I = LBound(t) To UBound(t) Step 2
If Not tArr(l) Then
If InStr("<>=", Left(t(I + 1), 1)) = 0 Then t(I + 1) = "=" & t(I + 1)
If InStr("<>=", Mid(t(I + 1), 2, 1)) > 0 Then Z = 2 Else Z = 1
tArr(l) = Application.Evaluate("NOT(""" & t(I).Item(l).Value & """" & Left(t(I + 1), Z) & """" & Mid(t(I + 1), Z + 1) & """)")
End If
Next I
Next l
For l = 1 To UBound(tArr)
If Not tArr(l) Then
splt = Split(cntArr(l, 1), delim)
For j = LBound(splt) To UBound(splt)
On Error Resume Next
dict.Add splt(j), splt(j)
On Error GoTo 0
Next j
End If
Next l
MyCount3 = dict.Count
End Function
It is entered similar to SUMIFS,COUNTIFS.
The first criterion is the range that needs to be split and counted.
The second is the delimiter on which it should split.
Then the rest is entered in pairs.
=MyCount3($C$2:$C$5,";",$A$2:$A$5,"A",$B$2:$B$5,"Y")
Consider:
Sub poiuyt()
Dim N As Long, i As Long, c As Collection
Set c = New Collection
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To N
If Cells(i, 1) = "A" And Cells(i, 2) = "Y" Then
arr = Split(Cells(i, 3), ";")
For Each a In arr
On Error Resume Next
c.Add a, CStr(a)
On Error GoTo 0
Next a
End If
Next i
MsgBox c.Count
End Sub
I took a different, possibly more complicated approach. You can specify the criteria directly on the sheet.
The function is UniqueNames(Range of Data, Range of Names, Range of Rules, Optional AndRules = True, Optional PrintNames = False)
Here is my sample sheet
I'm using the function 4 times in
- Range("E16") as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE)
- Range("E17") as UniqueNames(A1:F11,G1:G11,A13:B16)
- Range("F16") as UniqueNames(A1:F11,G1:G11,A13:B16,FALSE,TRUE)
- Range("F17") as UniqueNames(A1:F11,G1:G11,A13:B16,,TRUE)
The following operators for conditions are acceptable =,<,>,<=,>=,!=
The operator must be followed by a single space and either
- a constant value e.g. Complete
- a function of a value, e.g. Status(Project#6)
An empty condition is invalid
Here's the code: Note: There is a private function as well
Public Function UniqueNames(DataSource As Range, ResultsSource As Range, RulesSource As Range, _
Optional AndRules As Boolean = True, Optional PrintNames As Boolean = False) As String
' Return N unique names and who
' Split Indexed Expressions
Dim iChar As Integer
' Expression to eval
Dim Expression() As String
Dim expr As Variant
' Results
Dim Results As Variant
' Get Data into variant array
Dim Data As Variant
' Get Rules into variant array of NRows x 2
Dim Rules As Variant
iChar = 0
Data = DataSource
If RulesSource.Columns.Count = 1 Then
Rules = Union(RulesSource, RulesSource.Offset(0, 1))
ElseIf RulesSource.Columns.Count > 2 Then
Rules = RulesSource.Resize(RulesSource.Rows.Count, 2)
Else
Rules = RulesSource
End If
Results = ResultsSource.Resize(ResultsSource.Rows.Count, UBound(Rules))
For i = LBound(Rules) + 1 To UBound(Rules)
For j = LBound(Data, 2) To UBound(Data, 2)
If Rules(i, 1) = Data(1, j) Then
' rules must be "operator condition"
Expression = Split(Rules(i, 2), " ", 2)
Expression(1) = Trim(Expression(1))
' determine which expression is this
' Convert expression when an item of something e.g. EndDate(10)
iChar = InStr(Expression(1), "(")
If iChar > 0 Then
expr = ExprToVal(Data, Left$(Expression(1), iChar - 1), _
Mid$(Expression(1), iChar + 1, Len(Expression(1)) - iChar - 1))
Else
expr = Expression(1)
End If
For k = LBound(Data, 1) + 1 To UBound(Data, 1)
Results(k, i) = False
Select Case (Expression(0))
Case "="
If Data(k, j) <> "" And LCase$(Data(k, j)) = LCase$(expr) Then Results(k, i) = True
Case "<"
If Data(k, j) <> "" And LCase$(Data(k, j)) < LCase$(expr) Then Results(k, i) = True
Case ">"
If Data(k, j) <> "" And LCase$(Data(k, j)) > LCase$(expr) Then Results(k, i) = True
Case "<="
If Data(k, j) <> "" And LCase$(Data(k, j)) <= LCase$(expr) Then Results(k, i) = True
Case ">="
If Data(k, j) <> "" And LCase$(Data(k, j)) >= LCase$(expr) Then Results(k, i) = True
Case "!="
If Data(k, j) <> "" And LCase$(Data(k, j)) <> LCase$(expr) Then Results(k, i) = True
End Select
Next k
End If
Next j
Next i
' create one list where all three rules are true
Data = Results
Set Results = Nothing
ReDim Results(LBound(Data, 1) + 1 To UBound(Data, 1), 1 To 2) As Variant
' results now has the names w/a number representing how many rules were met
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
Results(i, 1) = Data(i, 1)
Results(i, 2) = 0
For j = LBound(Data, 2) + 1 To UBound(Data, 2)
If Data(i, j) Then Results(i, 2) = Results(i, 2) + 1
Next j
Next i
' put that back into data
Data = Results
Set Results = Nothing
Results = ""
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
If Data(i, 2) = UBound(Rules, 1) - LBound(Rules, 1) Then
Results = Results & Data(i, 1) & ";"
ElseIf AndRules = False And Data(i, 2) > 0 Then
Results = Results & Data(i, 1) & ";"
End If
Next i
' split that into expression
Expression = Split(Results, ";")
For i = LBound(Expression) To UBound(Expression)
For j = i + 1 To UBound(Expression)
If Expression(i) = Expression(j) Then Expression(j) = ""
Next j
Next i
iChar = 0
Results = ""
For i = LBound(Expression) To UBound(Expression)
If Expression(i) <> "" Then
Results = Results & Expression(i) & ";"
iChar = iChar + 1
End If
Next i
UniqueNames = ""
If PrintNames Then
' prints number of unique names and the names
UniqueNames = Results
Else
' prints number of unique names
UniqueNames = CStr(iChar)
End If
End Function
Private Function ExprToVal(Data As Variant, expr As String, Index As String) As Variant
Dim Row As Integer
Dim Col As Integer
Dim sCol As Variant
' Get what type of data this is
For i = LBound(Data, 2) To UBound(Data, 2)
sCol = Replace(Index, Data(1, i), "", 1, 1, vbTextCompare)
If IsNumeric(sCol) Then
Col = i
Exit For
ElseIf LCase$(Left$(Index, Len(Data(1, i)))) = LCase$(Data(1, i)) Then
Col = i
Exit For
End If
Next i
' now find the row of the value
For i = LBound(Data, 1) + 1 To UBound(Data, 1)
If LCase$(Data(i, Col)) = LCase$(sCol) Then
Row = i
Exit For
End If
Next i
' find the column of the value
For i = LBound(Data, 2) To UBound(Data, 2)
If LCase$(Data(1, i)) = LCase$(expr) Then
Col = i
Exit For
End If
Next i
If Row >= LBound(Data, 1) And Row <= UBound(Data, 1) And _
Col >= LBound(Data, 2) And Col <= UBound(Data, 2) Then
ExprToVal = Data(Row, Col)
Else
ExprToVal = ""
End If
End Function

Creating UDF using VBA in excel to find similar values in a row where order does not matter [closed]

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I am dealing with unlimited new rows of data every day and I need a UDF that would find similar row values regardless of its order. As you can see in the example bellow A9:F9 and A4:F4 has a similar row values marked as SIMILAR ROW 1. You need to look at the overall data within the row to see that it has same values but not in the same order. I’m not familiar with VBA if someone could please help me it would very well be appreciated. I have been searching for this all over the web now.
Formula Example:
=Similarity(Range Of Data from A:F, Row Of Data)
My sheet looks like below image:
pls. try with below code
Sub test()
Dim data() As String
Dim i As Long
Dim dd As Long
Dim lastrow As Variant
Dim lastcolumn As Variant
Dim status As Boolean
lastrow = Range("A" & Rows.Count).End(xlUp).Row
lastcolumn = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim data(lastrow - 1, lastcolumn)
For i = 2 To lastrow
For j = 1 To lastcolumn
data(i - 1, j) = Cells(i, j)
Next j
Next i
For i = 1 To lastrow - 1
Call similarity(data(), i)
Next i
End Sub
Public Function similarity(rdata() As String, currrow As Long)
lastrow = UBound(rdata)
matchcount = 0
lastcolumn = UBound(rdata, 2)
For Z = currrow To lastrow - 1
ReDim test(lastcolumn) As String
ReDim test1(lastcolumn) As String
For i = 1 To lastcolumn
test(i) = rdata(currrow, i)
test1(i) = rdata(Z + 1, i)
Next i
Call sort(test())
Call sort(test1())
For i = 1 To lastcolumn
If test(i) = test1(i) Then
matchcount = matchcount + 1
End If
Next i
If matchcount = lastcolumn Then
If Cells(currrow + 1, lastcolumn + 1).Value <> "" Then
Cells(currrow + 1, lastcolumn + 1).Value = Cells(currrow + 1, lastcolumn + 1).Value & "|" & "Match with " & Z + 2
Else
Cells(currrow + 1, lastcolumn + 1).Value = "Match with " & Z + 2
End If
If Cells(Z + 2, lastcolumn + 1).Value <> "" Then
Cells(Z + 2, lastcolumn + 1).Value = Cells(Z + 2, lastcolumn + 1).Value & "|" & "Match with " & currrow + 1
Else
Cells(Z + 2, lastcolumn + 1).Value = "Match with " & currrow + 1
End If
End If
matchcount = 0
Next Z
End Function
Sub sort(list() As String)
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim temp As String
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
temp = list(j)
list(j) = list(i)
list(i) = temp
End If
Next j
Next i
End Sub
Here is a start. It will help you to find which rows are permutations of other rows. Say we start with:
This UDF() will take the contents of a set of cells; sort the data; concatenate the data; and return the result as a single string:
Public Function SortRow(rng As Range) As String
ReDim ary(1 To rng.Count) As Variant
Dim CH As String, i As Long
CH = Chr(2)
For i = 1 To 6
ary(i) = rng(i)
Next i
Call aSort(ary)
SortRow = Join(ary, CH)
End Function
Public Sub aSort(ByRef InOut)
Dim i As Long, J As Long, Low As Long
Dim Hi As Long, Temp As Variant
Low = LBound(InOut)
Hi = UBound(InOut)
J = (Hi - Low + 1) \ 2
Do While J > 0
For i = Low To Hi - J
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
For i = Hi - J To Low Step -1
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
J = J \ 2
Loop
End Sub
So in G1 we enter:
=SortRow(A1:F1)
and copy down and in H1 enter:
=IF(COUNTIF($G$1:$G$7,G1)=1,"unique combination","duplicates")
and copy down:
This shows that rows 2 and 6 have data that are duplicated, but in different order.
Starting from this may help you achieve your goal.

Excel: Split ; separated cell values into columns and then shift in consecutive rows

I'm in the situation described by fig.1 where I have a cell with the reference name and a cell with one or more semicolon separated emails associated to the same reference. I'd like to split the cells contaning more than one email stacking them consecutively and copying the refence name. Is it possible to do this with a VBA Macro in Excel 2007? I know the existence of the "Split in columns" command, but I don't know how to automatically shift the columns in rows and copying the reference name. Thanks in advance.
Here you go:
Sub SplitColumnB()
Dim r As Range
Set r = [B2]
Do While r.Value <> ""
res = Split(r.Value, " ; ")
i = 0
For Each resStr In res
If i > 0 Then r.Offset(1).EntireRow.Insert xlDown
r.Offset(IIf(i > 0, 1, 0)).Value = resStr
r.Offset(IIf(i > 0, 1, 0), -1).Value = Right(resStr, Len(resStr) - InStr(resStr, "#"))
i = i + 1
Next
Set r = r.Offset(IIf(i > 0, i, 1))
Loop
End Sub
Try with the below code. Replace all instances of Sheet1 with the name of your worksheet.
Sub test()
Dim Ref As String
Dim Eid As String
Dim RefR()
Dim EidR()
Rcnt = Sheets("Sheet1").Range("A65000").End(xlUp).Row
K = 0
L = 0
For i = 2 To Rcnt
Ref = Sheets("Sheet1").Range("A" & i).Value
Temp = Split(Sheets("Sheet1").Range("B" & i).Value, ";")
K = K + 1
ReDim Preserve RefR(1 To K)
RefR(K) = Ref
For j = LBound(Temp) To UBound(Temp)
If L <= UBound(Temp) Then
ReDim Preserve EidR(Rcnt, L)
L = UBound(Temp)
End If
EidR(K, j) = Temp(j)
Next j
Next i
RowValue = 2
For i = 1 To UBound(RefR)
For j = 0 To L
Sheets("Sheet1").Range("A" & RowValue).Value = RefR(i)
Sheets("Sheet1").Range("B" & RowValue).Value = Trim(EidR(i, j))
RowValue = RowValue + 1
Next j
Next i
End Sub

How can i find a number after character in VBA?

How can I find a numeric number in the same cell after character. For ex After J* find number 01. I will have few rows and inside row some value will J*01 or J*08 im trying separate between character and number using instar in VBA:
Sub zz()
Dim ii As Long, z As Integer, xlastrow As Long
Dim yy As String
xlastrow = Worksheets("Sheet1").UsedRange.Rows.Count
For ii = 1 To xlastrow
yy = "J*"
z = 1
If IsNumeric(Worksheets("Sheet1").Range("B" & ii)) Then
This line separating number after J* character and pasting it to sheet2
Seprate.Find.Range("B" & ii, yy).Value = Worksheet("Sheet2").Range("A" & z)
End If
z = z + 1
Next ii
End Sub
Please try this code
' paste the values in column A.
q1w2e3r4asJ*66bvft654
1234BA
BA1234BA
xuz12354
''''' Code
Option Explicit
Sub Remove_Charecter()
Dim Last_Row As Double
Dim num As Double
Dim i As Integer
Dim j As Integer
Last_Row = Range("A65536").End(xlUp).Row
For i = 1 To Last_Row
num = 0
For j = 1 To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = (num)
Next i
'MsgBox num
End Sub
'--- Output will be
123466654
1234
1234
12354
Try the below piece of codes.
Assumption
Your data that you need to separate is in Column A
There is no blank cells in your data
Trim value will be displayed in the adjacent column i.e. Column B in subsequent cells
Code :
Dim LRow As Double
Dim i As Integer
Dim j As Integer
Dim LPosition As Integer
Dim Number As Double
LRow = Range("A1").End(xlDown).Row
For i = 1 To LRow
Number = 0
LPosition = InStr(1, Cells(i, 1), "J*")
For j = (LPosition + 2) To Len(Cells(i, 1))
If IsNumeric(Mid(Cells(i, 1), j, 1)) Then
num = Trim(num & Mid(Cells(i, 1), j, 1))
End If
Next j
Cells(i, 2).Value = Number
Next i

How to reverse the order of rows

I try to write a macro that would reverse order of rows in my Excel worksheet, but unfortunately I fail. I don not know even how to start. I would be very grateful for any help or hints on how to do it.
Select your rows and run this macro:
Sub ReverseList()
Dim firstRowNum, lastRowNum, thisRowNum, lowerRowNum, length, count As Integer
Dim showStr As String
Dim thisCell, lowerCell As Range
With Selection
firstRowNum = .Cells(1).Row
lastRowNum = .Cells(.Cells.count).Row
End With
showStr = "Going to reverse rows " & firstRowNum & " through " & lastRowNum
MsgBox showStr
showStr = ""
count = 0
length = (lastRowNum - firstRowNum) / 2
For thisRowNum = firstRowNum To firstRowNum + length Step 1
count = count + 1
lowerRowNum = (lastRowNum - count) + 1
Set thisCell = Cells(thisRowNum, 1)
If thisRowNum <> lowerRowNum Then
thisCell.Select
ActiveCell.EntireRow.Cut
Cells(lowerRowNum, 1).EntireRow.Select
Selection.Insert
ActiveCell.EntireRow.Cut
Cells(thisRowNum, 1).Select
Selection.Insert
End If
showStr = showStr & "Row " & thisRowNum & " swapped with " & lowerRowNum & vbNewLine
Next
MsgBox showStr
End Sub
Comment out the MsgBox if you don't like notifications.
I simplified Wallys code a little and changed it, so that it has the row numbers as input parameters:
Sub ReverseList(firstRowNum As Integer, lastRowNum As Integer)
Dim upperRowNum, lowerRowNum, length As Integer
length = (lastRowNum - firstRowNum - 2) / 2
For upperRowNum = firstRowNum To firstRowNum + length Step 1
lowerRowNum = lastRowNum - upperRowNum + firstRowNum
Cells(upperRowNum, 1).EntireRow.Cut
Cells(lowerRowNum, 1).EntireRow.Insert
Cells(lowerRowNum, 1).EntireRow.Cut
Cells(upperRowNum, 1).EntireRow.Insert
Next
End Sub
Tobi
I extended Tobag's answer with a Range parameter, and making all arguments optional:
Sub ReverseRows(Optional rng As range = Nothing, Optional firstRowNum As Long = 1, Optional lastRowNum As Long = -1)
Dim i, firstRowIndex, lastRowIndex As Integer
' Set default values for dynamic parameters
If rng Is Nothing Then Set rng = ActiveSheet.UsedRange
If lastRowNum = -1 Then lastRowNum = rng.Rows.Count
If firstRowNum <> 1 Then
' On each loop, cut the last row and insert it before row 1, 2, 3, and so on
lastRowIndex = lastRowNum
For i = firstRowNum To lastRowNum - 1 Step 1
firstRowIndex = i
rng.Rows(lastRowIndex).EntireRow.Cut
rng.Rows(firstRowIndex).EntireRow.Insert
Next
Else
' Same as above, except handle different Insert behavior.
' When inserting to row 1, the insertion goes above/outside rng,
' thus the confusingly different indices.
firstRowIndex = firstRowNum
For i = firstRowNum To lastRowNum - 1 Step 1
lastRowIndex = lastRowNum - i + 1
rng.Rows(lastRowIndex).EntireRow.Cut
rng.Rows(firstRowIndex).EntireRow.Insert
Next
End If
End Sub