Related
I'm new to VBA and what I have so far is mashup from various tutorials and websearches. But so far it works how I want. Now I'd like to add search option and after hours of websearch I cannot find right solution.
Basically I'm trying to create userform which shows data from sheet in listbox, when I double-click item on listbox it shows values of defined cell in textboxes and checkboxes. Got that. I'd like to add search option to list results in same cleared listbox without duplicates (if searched value appears multiple times in same row list it only once in listbox) and when I double-click on an item in listbox it will show details of that record in userform textboxes with checkbox values. All works fine with CheckBox1 changing colours aswell.
What I tried so far.
My listbox populates with all data and on double click shows everything properly.
Sub All_Data()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("TABLE")
Dim last_Row As Long
last_Row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
With Me.ListBox1
.ColumnHeads = False
.ColumnCount = 12
.ColumnWidths = "0,70,60,60,0,0,0,0,0,0,120,0"
.List = Range(Cells(1, 1), Cells(last_Row, .ColumnCount)).Value
.RemoveItem 0
End With
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.TextBox1.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 0)
Me.TextBox2.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
Me.TextBox3.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 2)
Me.TextBox4.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 3)
Me.TextBox5.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 4)
Me.TextBox6.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 5)
Me.TextBox7.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 6)
Me.ComboBox1.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 7)
Me.Checkbox1.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 8)
Me.Checkbox2.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 9)
Me.CheckBox3.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 10)
Me.CheckBox4.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 11)
End Sub
Private Sub CheckBox1_Change()
If CheckBox1.Value Then
CheckBox1.ForeColor = &H8000&
Else
CheckBox1.ForeColor = &HC0&
End If
End Sub
Private Sub Workbook_Open()
UserForm1.Show
End Sub
Checkbox values are changing properly from red to green and vice versa.
cbgreen cbred
Then I tried to add search option and it kind of works, but checkbox values being greyed out despite showing right true value (but still works with all data listed).
cbgrey
Private Sub searchButton_Click()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("TABLE")
Dim i As Long
Dim x As Long
Dim p As Integer, k As Integer
Me.searchTextBox = LCase(Me.searchTextBox)
If Me.searchTextBox = "" Then
Call All_Data
Exit Sub
End If
With Me.ListBox1
.Clear
.ColumnHeads = False
.ColumnCount = 12
.ColumnWidths = "0,70,60,60,0,,0,0,0,0,120,0"
For i = 2 To sh.Range("A" & Rows.Count).End(xlUp).Row
For x = 1 To Len(sh.Cells(i, 2))
p = Me.searchTextBox.TextLength
For k = 2 To .ColumnCount - 4
If LCase(Mid(sh.Cells(i, k), x, p)) = Me.searchTextBox And Me.searchTextBox <> "" Then
.AddItem
.List(.ListCount - 1, 0) = sh.Cells(i, 1).Value
.List(.ListCount - 1, 1) = sh.Cells(i, 2).Value
.List(.ListCount - 1, 2) = sh.Cells(i, 3).Value
.List(.ListCount - 1, 3) = sh.Cells(i, 4).Value
.List(.ListCount - 1, 4) = sh.Cells(i, 5).Value
.List(.ListCount - 1, 5) = sh.Cells(i, 6).Value
.List(.ListCount - 1, 6) = sh.Cells(i, 7).Value
.List(.ListCount - 1, 7) = sh.Cells(i, 8).Value
.List(.ListCount - 1, 8) = sh.Cells(i, 9).Value
.List(.ListCount - 1, 9) = sh.Cells(i, 10).Value
.List(.ListCount - 1, 10) = sh.Cells(i, 11).Value
.List(.ListCount - 1, 11) = sh.Cells(i, 12).Value
End If
Next k
Next x
Next i
RemoveDuplicates Listbox1
End With
End Sub
Sub RemoveDuplicates(aListBox As MSForms.ListBox)
Dim i As Long, j As Long
With aListBox
For i = .ListCount - 1 To 1 Step -1
For j = 0 To i - 1
If (.List(i, 0) = .List(j, 0)) Or (.List(i, 0) = vbNullString) Then
.RemoveItem i
Exit For
End If
Next j
Next i
End With
End Sub
Is there another way to search, list results in listbox without duplicates and on double-click to populate values to textboxes and ComboBox1 not greyed out (changing colour)?
Thank you for any suggestions and help.
Avoid the duplicates by exiting the column loop at the first match.
Option Explicit
Const COLWIDTHS = "0,70,60,60,0,,0,0,0,0,120,0"
Private Sub searchButton_Click()
Dim sh As Worksheet, data
Dim s As String, lastrow As Long
Dim i As Long, j As Long, k As Long, n As Long
s = Trim(LCase(Me.searchTextBox)) ' search term
If Len(s) = 0 Then
Call All_Data
Exit Sub
End If
With Me.ListBox1
.Clear
.ColumnHeads = False
.ColumnCount = 12
.ColumnWidths = COLWIDTHS
End With
Set sh = ThisWorkbook.Sheets("TABLE")
With sh
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
' use array to speed up search
data = .Range("A1:L" & lastrow).Value2 ' 12 columns
End With
'search
n = 0 ' list index
s = "*" & s & "*" ' like
For i = 2 To lastrow
For j = 2 To 8 ' search col B to H
If LCase(data(i, j)) Like s Then
With Me.ListBox1
.AddItem
For k = 1 To 12 ' Col A to L
.List(n, k - 1) = data(i, k)
Next
n = n + 1
End With
Exit For
End If
Next
Next
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim n As Long, i As Long, c As Control
With Me.ListBox1
i = .ListIndex
If i < 0 Then Exit Sub
For n = 1 To 7 ' A to G
Set c = Me.Controls("TextBox" & n)
c.Value = .List(i, n - 1)
Next
Me.ComboBox1.Value = .List(i, 7) ' col H
For n = 9 To 12 ' col I - L
Set c = Me.Controls("CheckBox" & n - 8)
If .List(i, n - 1) = 1 Then
c.Value = True
c.ForeColor = &H8000&
Else
c.Value = False
c.ForeColor = &HC0&
End If
Next
End With
End Sub
Sub All_Data()
Dim sh As Worksheet, last_Row As Long
Set sh = ThisWorkbook.Sheets("TABLE")
With sh
last_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With Me.ListBox1
.ColumnHeads = False
.ColumnCount = 12
.ColumnWidths = COLWIDTHS
.List = sh.Range(sh.Cells(2, 1), sh.Cells(last_Row, .ColumnCount)).Value
End With
End Sub
' repeat for checkboxes 2,3 4
Private Sub CheckBox1_Change()
If CheckBox1.Value Then
CheckBox1.ForeColor = &H8000&
Else
CheckBox1.ForeColor = &HC0&
End If
End Sub
Private Sub Workbook_Open()
UserForm1.Show
End Sub
Private Sub UserForm_Activate()
All_Data
End Sub
I am creating an Excel userform in which users can add, search, and update records. I was able to create a button command that searches the database (a single sheet in my workbook) and populates a listbox with the search results. Because my database has more than 10 columns which I wanted to be visible in the listbox, I used an array to populate the listbox rather than AddItem which limited me to 10 or fewer columns. (the search code is below)
Private Sub Search_Click()
''''''''''''Validation
If Trim(SearchTextBox.Value) = "" And Me.Visible Then
MsgBox "Please enter a search value.", vbCritical, "Error"
Exit Sub
End If
ReDim arrs(0 To 17, 1 To 1)
With Worksheets("Sheet1")
ListBox.Clear
ListBox.ColumnCount = 18
ListBox.ColumnHeads = True
ListBox.Font.Size = 10
ListBox.ColumnWidths = "80,80,150,130,90,90,80,80,80,80,80,60,70,150,150,150,150,180"
If .FilterMode Then .ShowAllData
Set k = .Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row).Find(What:="*" & SearchTextBox.Text & "*", LookIn:=xlValues, lookat:=xlWhole)
If Not k Is Nothing Then
adrs = k.Address
Do
M = M + 1
ReDim Preserve arrs(0 To 17, 1 To M)
For j = 0 To 17
arrs(j, M) = .Cells(k.Row, j + 1).Value
Next j
Set k = .Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adrs
ListBox.Column = arrs
Else
' If you get here, no matches were found
MsgBox "No matches were found based on the search criteria.", vbInformation
End If
End With
End Sub
I also added code so that when I double click on a record in the listbox, it populates the corresponding textbox in the userform.
Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1.Text = ListBox.Column(0)
If TextBox1.Text = ListBox.Column(0) Then
TextBox1.Text = ListBox.Column(0)
TextBox2.Text = ListBox.Column(1)
TextBox3.Text = ListBox.Column(2)
TextBox4.Text = ListBox.Column(3)
TextBox5.Text = ListBox.Column(4)
TextBox6.Text = ListBox.Column(5)
TextBox7.Text = ListBox.Column(6)
TextBox8.Text = ListBox.Column(7)
TextBox9.Text = ListBox.Column(8)
TextBox10.Text = ListBox.Column(9)
TextBox11.Text = ListBox.Column(10)
TextBox12.Text = ListBox.Column(11)
TextBox13.Text = ListBox.Column(12)
TextBox14.Text = ListBox.Column(13)
TextBox15.Text = ListBox.Column(14)
TextBox16.Text = ListBox.Column(15)
TextBox17.Text = ListBox.Column(16)
TextBox18.Text = ListBox.Column(17)
End If
End Sub
After double clicking on a search result from the listbox, I want users to be able to edit any information in those textboxes and click a command button to update that entry/record in the database itself. However, I am having some problems with creating this function. I used the following code, and although it doesn't return an error message, it doesn't change the entry in the database.
Dim X As Long
Dim Y As Long
X = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For Y = 2 To X
If Sheets("Sheet1").Cells(Y, 11).Value = SearchTextBox.Text Then
Sheets("Sheet1").Cells(Y, 1).Value = TextBox1
Sheets("Sheet1").Cells(Y, 2).Value = TextBox2
Sheets("Sheet1").Cells(Y, 3).Value = TextBox3
Sheets("Sheet1").Cells(Y, 4).Value = TextBox4
Sheets("Sheet1").Cells(Y, 5).Value = TextBox5
Sheets("Sheet1").Cells(Y, 6).Value = TextBox6
Sheets("Sheet1").Cells(Y, 7).Value = TextBox7
Sheets("Sheet1").Cells(Y, 8).Value = TextBox8
Sheets("Sheet1").Cells(Y, 9).Value = TextBox9
Sheets("Sheet1").Cells(Y, 10).Value = TextBox10
Sheets("Sheet1").Cells(Y, 11).Value = TextBox11
Sheets("Sheet1").Cells(Y, 12).Value = TextBox12
Sheets("Sheet1").Cells(Y, 13).Value = TextBox13
Sheets("Sheet1").Cells(Y, 14).Value = TextBox14
Sheets("Sheet1").Cells(Y, 15).Value = TextBox15
Sheets("Sheet1").Cells(Y, 16).Value = TextBox16
Sheets("Sheet1").Cells(Y, 17).Value = TextBox17
Sheets("Sheet1").Cells(Y, 18).Value = TextBox18
End If
Next Y
Additionally, the term that I am searching with is not unique, so there are multiple records/rows in the database with the same search term. How can I create this code in a way that I when I click on the update button, information from the userform (which has been populated by doubleclicking the record in the listbox) is updated in the excel sheet but not for all records with the same search term?
Thank you so much for any help!
Add a Label to your UserForm to hold the row number from where the text box values came. Use the first column (width zero so hidden) of the listbox to hold the row number of the filtered rows. Set the label to column 0 of the double clicked row.
Option Explicit
Private Sub Update_Click()
Dim r As Long, n As Long
' record showing
r = Val(Label1.Caption)
If r < 1 Then
Exit Sub
End If
With Sheets("Sheet1")
For n = 1 To 18
.Cells(r, n).Value2 = Me.Controls("TextBox" & n)
Next
End With
End Sub
Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim n As Long
With ListBox
For n = 1 To ListBox.ColumnCount - 1
Debug.Print n, .Column(n)
Me.Controls("TextBox" & n).Text = .Column(n)
Next
Label1.Caption = .Column(0)
End With
End Sub
Private Sub Search_Click()
Const COLS = 18
Dim s
s = Trim(SearchTextBox.Value)
If s = "" And Me.Visible Then
MsgBox "Please enter a search value.", vbCritical, "Error"
Exit Sub
Else
s = "*" & s & "*"
End If
Dim rngFnd As Range, rngSearch As Range, first As String
Dim arr, lastrow As Long, i As Long, j As Long
' search sheet
With Worksheets("Sheet1")
If .FilterMode Then .ShowAllData
lastrow = .Cells(.Rows.Count, "K").End(xlUp).Row
Set rngSearch = .Range("K1:K" & lastrow)
i = WorksheetFunction.CountIf(rngSearch, s)
If i > 0 Then
ReDim arr(0 To COLS, 1 To i)
Set rngFnd = rngSearch.Find(What:=s, LookIn:=xlValues, lookat:=xlWhole)
If Not rngFnd Is Nothing Then
i = 0
first = rngFnd.Address
Do
i = i + 1
arr(0, i) = rngFnd.Row
For j = 1 To COLS
arr(j, i) = .Cells(rngFnd.Row, j).Value
Next j
Set rngFnd = rngSearch.FindNext(rngFnd)
Loop While rngFnd.Address <> first
End If
Else
'If you get here, no matches were found
MsgBox "No matches were found based on the search criteria. " & s, vbExclamation
Exit Sub
End If
End With
' format listbox
With ListBox
.Clear
.ColumnCount = COLS + 1
.ColumnHeads = True
.Font.Size = 10
.ColumnWidths = "0,80,80,150,130,90,90,80,80,80,80,80,60,70,150,150,150,150,180"
.Column = arr
End With
End Sub
Background:
I'm trying to write a module to concatenate strings with it's formatting. Therefor I'm looking in all Font properties that could matter, including Subscript and Superscript.
Sample Data:
Imagine in A1:
Sample Code:
Sub Test()
With Sheet1.Range("B1")
.Value = .Offset(0, -1).Value
For x = 1 To .Characters.Count
.Characters(x, 1).Font.Subscript = .Offset(0, -1).Characters(x, 1).Font.Subscript
.Characters(x, 1).Font.Superscript = .Offset(0, -1).Characters(x, 1).Font.Superscript
Next x
End With
End Sub
Result:
Question:
If I would go through this code step-by-step using F8 I can see the characters that are supposed to be subscript become subscript, but will loose it's properties value when the superscript value is passed. The other way around works fine, meaning the superscript properties stay intact.
This procedure is part of a larger procedure where for example I tried to convert this:
Sub ConcatStringsWithFormat()
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim props(9) As Variant, arr As Variant
Dim rng As Range
Dim x As Long, y As Long: y = 0
Set rng = Sheet1.Range("A1:A3")
With Application
.Trim (rng)
arr = rng: arr = .Transpose(.Index(arr, 0, 1))
End With
For Each cell In rng
If Len(cell) > 0 Then
y = y + 1
For x = 1 To cell.Characters.Count
props(0) = cell.Characters(x, 1).Font.Bold
props(1) = cell.Characters(x, 1).Font.ColorIndex
props(2) = cell.Characters(x, 1).Font.FontStyle
props(3) = cell.Characters(x, 1).Font.Italic
props(4) = cell.Characters(x, 1).Font.Size
props(5) = cell.Characters(x, 1).Font.Strikethrough
props(6) = cell.Characters(x, 1).Font.Subscript
props(7) = cell.Characters(x, 1).Font.Superscript
props(8) = cell.Characters(x, 1).Font.TintAndShade
props(9) = cell.Characters(x, 1).Font.Underline
dict.Add y, props
y = y + 1
Next x
End If
Next cell
With Sheet1.Cells(1, 2)
.Value = Application.Trim(Join(arr, " "))
For x = 1 To .Characters.Count
If Mid(.Value, x, 1) <> " " Then
.Characters(x, 1).Font.Bold = dict(x)(0)
.Characters(x, 1).Font.ColorIndex = dict(x)(1)
.Characters(x, 1).Font.FontStyle = dict(x)(2)
.Characters(x, 1).Font.Italic = dict(x)(3)
.Characters(x, 1).Font.Size = dict(x)(4)
.Characters(x, 1).Font.Strikethrough = dict(x)(5)
.Characters(x, 1).Font.Subscript = dict(x)(6)
.Characters(x, 1).Font.Superscript = dict(x)(7)
.Characters(x, 1).Font.TintAndShade = dict(x)(8)
.Characters(x, 1).Font.Underline = dict(x)(9)
End If
Next x
End With
End Sub
Resulting in:
As you can see, it's just the subscript properties that get lost. Any thought on why this happens and also on how to overcome this? It's apparent that a cell will allow both properties to be true on different characters if you manually tried this.
Just test before setting those properties:
Sub Test()
With Sheet1.Range("B2")
.Value = .Offset(0, -1).Value
For x = 1 To .Characters.Count
If .Offset(0, -1).Characters(x, 1).Font.Subscript Then
.Characters(x, 1).Font.Subscript = True
ElseIf .Offset(0, -1).Characters(x, 1).Font.Superscript Then
.Characters(x, 1).Font.Superscript = True
End If
Next x
End With
End Sub
Just found out that swapping the lines will give the correct result:
Wrong
With Sheet1.Range("B1")
.Value = .Offset(0, -1).Value
For x = 1 To .Characters.Count
.Characters(x, 1).Font.Subscript = .Offset(0, -1).Characters(x, 1).Font.Subscript
.Characters(x, 1).Font.Superscript = .Offset(0, -1).Characters(x, 1).Font.Superscript
Next x
End With
Right
With Sheet1.Range("B1")
.Value = .Offset(0, -1).Value
For x = 1 To .Characters.Count
.Characters(x, 1).Font.Superscript = .Offset(0, -1).Characters(x, 1).Font.Superscript
.Characters(x, 1).Font.Subscript = .Offset(0, -1).Characters(x, 1).Font.Subscript
Next x
End With
Swapping the lines around worked. With no other explaination than that these properties are also below eachother under cell settings.
I am trying to write a code that will take one cell and then iterate through another column to find a match, once it has found a match it will then match two other cells in that same row and return the value of a 5th and 6th cell. However, it is not working! any suggestions??
Sub rates()
Dim i As Integer
For i = 2 To 2187
If Cells(i, 1).Value = Cells(i, 11).Value Then
If Cells(i, 2).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
Else
Cells(i, 24) = "No match"
End If
End If
Next i
End Sub
Try fully qualifying your cell objects i.e. sheet1.cells(i,1).value etc or encase within a with statement i.e.
with sheet1
if .cells(i,X) = .cells(i,Y) then
'...etc
end with
I think the default property for a range is "Value" but try putting .Value on to the end of all those Cell lines too... like you have for half of them :)
[EDIT/Addition:]
... failing that, you're not actually searching a whole column at any point: try something like:
Sub rates()
Dim i As Integer
Dim rgSearch As Range
Dim rgMatch As Range
Dim stAddress As String
Dim blMatch As Boolean
With wsSheet
Set rgSearch = .Range(.Cells(x1, y1), .Cells(x2, y2)) ' Replace where appropriate (y = 1 or 11 i guess, x = start and end row)
End With
For i = 2 To 2187
Set rgMatch = rgSearch.Find(wsSheet.Cells(i, y)) ' y = 1 or 11 (opposite of above!)
blMatch = False
If Not rgMatch Is Nothing Then
stAddress = rgMatch.Address
Do Until rgMatch Is Nothing Or rgMatch.Address = stAddress
If rgMatch.Offset(0, y).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
blMatch = True
Else
End If
Set rgMatch = rgSearch.FindNext(rgMatch)
Loop
End If
If Not blMatch Then
Cells(i, 24) = "No match"
End If
Next i
End Sub
I've made a lot of assumptions in there and there's a few variables you'll have to replace. You could also probably use application.worksheetfunction.match but .find is quicker and more awesome
I have code that will insert the number of rows based on data missing between 2 numbers but I am unable to figure out the code to get it to copy and paste the years I am missing.
Thanks in advance for any help, I am pretty good at manipulating existing code but I can't find any code to add to this to make it work
Here is the code I have to insert the right number of blank rows
Public Sub Insert()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
lastRow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Cells(lastRow, 1).Select
Set CurrentCell = ActiveSheet.Cells(lastRow, 1)
For n = lastRow To 0 Step -1
If n = lastRow Then GoTo CheckLastRow
If n = 1 Then GoTo CheckfirstRow
ActiveCell.Offset(-2, 0).Select
CheckLastRow:
Set NextCell = CurrentCell.Offset(-1, 0)
ActiveCell.Offset(1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Set CurrentCell = NextCell
Next n
'To be performed on the firstrow in the column
CheckfirstRow:
ActiveCell.Offset(-1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
My data looks like this
Column A is number of Rows I need Column B&C has years
B = 2009
C = 2013
It would need the output to copy the line and look like
2009 2010
2010 2011
2011 2012
2012 2013
I added this to the code and I still only have blank lines
Public Sub InsertTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
lastRow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Cells(lastRow, 1).Select
Set CurrentCell = ActiveSheet.Cells(lastRow, 1)
For n = lastRow To 0 Step -1
If n = lastRow Then GoTo CheckLastRow
If n = 1 Then GoTo CheckfirstRow
ActiveCell.Offset(-2, 0).Select
CheckLastRow:
Set NextCell = CurrentCell.Offset(-1, 0)
ActiveCell.Offset(1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
With Worksheets("Sheet1")
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
For j = 0 To YearDifference - 1
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End With
Set CurrentCell = NextCell
Next n
'To be performed on the firstrow in the column
CheckfirstRow:
ActiveCell.Offset(-1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
TESTED
First off, you should always avoid using Select and ActiveCell as described here.
Try adding the following loop before your Set CurrentCell = NextCell line:
With Worksheets("Sheet1")
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
For j = 0 To YearDifference - 1
.Cells(n + j, 1).Value = .Cells(n, 1).Value
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End With
You'll need to change the sheet reference as necessary and you should dimension the variables at the beginning of your code.
EDIT
Replace your code with this and it should work:
Sub InsertTest()
Dim LastRow As Long
Dim newYear As Long
Dim YearDifference As Long
Dim n As Long, j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Sheet1")
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
For n = LastRow To 1 Step -1
If n Mod 10 = 0 Then DoEvents
If .Cells(n, 1).Value <> "" Then
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
If YearDifference > 1 Then
Application.StatusBar = "Updating Row #" & n
.Range(.Cells(n + 1, 1), .Cells(n + YearDifference - 1, 15)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For j = 0 To YearDifference - 1
.Rows(n + j).Value = .Rows(n).Value
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End If
End If
Next n
End With
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
EDIT 2 - The code now includes a DoEvents line that runs every 10 iterations. This frees up some resources so that the code will run in the background. For a sheet with 27,000 rows like yours, it may take a couple hours to run the code, but you should be able to do other things in the meantime. I've also added a line to update the status bar so you can see which row the code is on.