I have a named range that looks like:
For each row where column 2 equals zero I want to white out the row from columns A:F (the six columns). What I have does not work as it selects the entire named range and whites the whole thing out when the if statement becomes true.
Sub modFinishFinancialEstimate()
Dim myrange As Range
Dim ws As Worksheet
Set myrange = Range("actual_cost_of_svc")
Set ws = ActiveSheet
ws.Select
For i = myrange.Rows(1).row To myrange.Rows.Count
MsgBox "The Count of services is " & Cells(i, 2).Value
If Range("B" & i).Value = 0 Then
MsgBox "The value is " & Cells(i, 2).Value & " and will be whited out"
For Each col In myrange.Columns
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
ActiveWorkbook.ws.Sort.SortFields.Add Key:=Range( _
myrange), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With Selection.Sort
.SetRange myrange
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next col
End If
Next
End Sub
The problem I encounter with the code above is that it checks the first row only and then exits the sub.
The first row will be
msgbox myrange.rows(1).row
You don't need to Select anything.
Alternatively, you could make your loop relative, i.e. the ith cell of myrange rather than the ith cell of the worksheet.
Related
I am trying to implement a button that, when pressed sorts an array first alphabetically, then based on font color. The column that I am using to sort has 3 possible values (enrolled, waitlisted, and cancelled). The font color for 'cancelled' is grey. I want to get enrolled at the top of the list, then waitlisted, then cancelled at the bottom. Shouldn't be that difficult, but I can't get the code to work. Here's the code I wrote. Many thanks!
Private Sub btnSort_Click()
Dim SortArray As Range
Dim SortColumn As Range
Set SortArray = Range("A3").CurrentRegion
Set SortColumn = Range(Range("A3").End(xlToRight), Range("A3").End(xlToRight).End(xlDown))
SortArray.Sort Key1:=SortColumn, Header:=xlYes
With SortArray.Sort
.SortFields.Clear
.SortFields.Add Key:=SortColumn
.xlSortOnFontColor
.SortOnValue.Color = RGB(192, 192, 192)
.SortOrder = xlAscending
.Header = xlYes
.Apply
End With
Since there are only 3 values, we use a helper column and then assign values to it. We then sort and then finally delete the helper column.
Let's say, your data looks like this
Try this code. I have commneted the code so you should not have a problem in understanding it.
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim rng As Range
Dim ColName As String
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Insert a helper column in Col A
.Columns(1).Insert Shift:=xlToRight
.Cells(1, 1).Value = "TmpHeader"
'~~> Get Last Row and last Column
'~~> I am assuming that headers are in row 1
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
ColName = Split(Cells(, lCol).Address, "$")(1)
'~~> Insert the formula in Col A
.Range("A2:A" & lRow).Formula = "=IF(RC[1]=""enrolled"",1,IF(RC[1]=""waitlisted"",2,3))"
'~~> Set your range
Set rng = .Range("A1:" & ColName & lRow)
'~~> Sort it
rng.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'~~> Delete the helper column
.Columns(1).Delete
End With
End Sub
When you run the above code, it inserts a helper column and then inserts a formula =IF(B2="enrolled",1,IF(B2="waitlisted",2,3)) What this basically does is assigns a value of 1,2 and 3 based on the value whether it is enrolled, waitlisted or cancelled.
Once the formula is inserted, we sort on Col A in ascending order and then finally delete the helper column.
Figured it out:
ActiveSheet.Range("A3").CurrentRegion.Sort Key1:=Range("I3"), Header:=xlYes
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add(Range("I3"), _
xlSortOnFontColor, xlDescending, , _
xlSortNormal).SortOnValue.Color = RGB(192, 192, 192)
With ActiveSheet.Sort
.SetRange Range("A3").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
I know my code looks like Frankenstein for take bits around the web, but it does work on my computer. Yet, when I try to run it on another computer (that has the same Excel 2016 version), it gives me
run-time error '9': subscription out of range
Why?
I have been doing some iterations such as removing activeworkbook to deal with various error it was giving but the error keeps changing. In addition, this time, the VBA debugger does not even give me a yellow line to check.
Sub CombineAll()
'Stop, delete sheet and activate Alerts
Application.DisplayAlerts = False
Sheets("Programmation générale").Delete
Application.DisplayAlerts = True
'Insert a new worksheet. Assign it to a name. Place it before Index
Set NewWs = Worksheets.Add(Before:=Worksheets("Index"))
NewWs.Name = "Programmation générale"
'Loop to copy worksheets
NextRow = 1
For Each ws In ThisWorkbook.Worksheets
If Not NewWs.Name = ws.Name Then
If Not Sheet1.Name = ws.Name Then
finalRow = ws.Cells(Rows.Count, 1).End(xlUp).Row - 1
ws.Cells(2, 1).Resize(finalRow, 14).Copy NewWs.Cells(NextRow, 1)
NextRow = NextRow + finalRow
End If
End If
Next ws
'Copy header
Sheet3.Range("A1:N1").Copy
NewWs.Range("A1").Rows("1:1").Insert Shift:=xlDown
'Select the new worksheet and transform into table
NewWs.Select
Dim src As Range
Set src = Range("B5").CurrentRegion
Set NewWs = ActiveSheet
NewWs.ListObjects.Add(SourceType:=xlSrcRange, Source:=src, _
xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleMedium15").Name = "ProgrammationGenerale"
'Arrange the table to specifications
Range("ProgrammationGenerale[#All]").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveSheet.Columns("A:N").AutoFit
Dim finalRowTable As Integer
Dim i As Integer
finalRowTable = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:A" & finalRow).EntireRow.AutoFit
For i = 2 To finalRow
If Range("A" & i).EntireRow.RowHeight < 27 Then
Range("A" & i).EntireRow.RowHeight = 27
End If
Next if
ActiveSheet.Range("D:F").EntireColumn.Hidden = True
ActiveSheet.Range("H:J").EntireColumn.Hidden = True
With ThisWorkbook.Worksheets("Programmation générale").ListObjects("ProgrammationGenerale").Sort
.SortFields.Clear
.SortFields.Add _
Key:=.Parent.ListColumns("Début_Date").DataBodyRange, SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Arrange for printing
ActiveSheet.PageSetup.Orientation = xlLandscape
ActiveSheet.PageSetup.PaperSize = xlPaperLegal
End Sub
I created this program for a spreadsheet in my work.
My code works almost all the time, but some times it decides to bug without any reason. (It doesn't show any error message, it just don't do what it was supposed to do. It when it sorts, sometimes it copies other row's information, but it should be all blank)
My program is basically sorting automatically two stacked tables in the same sheet.
CODE:
Option Explicit
Sub Sorting()
' Keyboard Shortcut: Ctrl+m
'
'******************************* Define variables for the data that I want to store for later use
Dim MyDataFirstCell
Dim MyDataLastCell
Dim MySortCellStart
Dim MySortCellEnd
Dim MyDataFirstCell2
Dim MyDataLastCell2
Dim MySortCellStart2
Dim MySortCellEnd2
'************************** Establish the Data Area
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select
DoEvents
MyDataFirstCell = ActiveCell.Address 'Get the first cell address of Data Area
Selection.End(xlDown).Select 'Get to Bottom Row of the data
Selection.End(xlToRight).Select 'Get to the last Column and data cell by heading to the righthand end
Selection.End(xlToRight).Select
ActiveCell.Offset(-1, 0).Select ' Select the correct last cell
MyDataLastCell = ActiveCell.Address 'Get the Cell address of the last cell of my data area
'************************** Establish the Sort column first and last data points.
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select 'Get to first cell of data sort Column (Example Col 'R' Row 2 becuase Row 1 contains the header)
DoEvents
MySortCellStart = ActiveCell.Address 'Get the Cell address of the first cell of my data sort Column
Selection.End(xlDown).Select 'Get to the bottom Row of data
ActiveCell.Offset(-1, 0).Select
MySortCellEnd = ActiveCell.Address 'Get the Cell address of the last cell of my sort Column
'************************** Start the sort by specifying sort area and columns
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add _
Key:=Range(MySortCellStart & ":" & MySortCellEnd), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range(MyDataFirstCell & ":" & MyDataLastCell)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Second sorting
'************************** Establish the Data Area
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
'Next Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
DoEvents
ActiveCell.Offset(1, 0).Select
Loop
DoEvents
ActiveCell.Offset(1, 0).Select
MyDataFirstCell2 = ActiveCell.Address 'Get the first cell address of Data Area
Selection.End(xlDown).Select 'Get to Bottom Row of the data
Selection.End(xlToRight).Select 'Get to the last Column and data cell by heading to the righthand end
Selection.End(xlToRight).Select
ActiveCell.Offset(-1, 0).Select ' Select the correct last cell
MyDataLastCell2 = ActiveCell.Address 'Get the Cell address of the last cell of my data area
'************************** Establish the Sort column first and last data points.
ActiveSheet.Range("B1").Select
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
'Next Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
'Next Non Blank Cell down
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select 'Get to first cell of data sort Column (Example Col 'R' Row 2 becuase Row 1 contains the header)
MySortCellStart2 = ActiveCell.Address 'Get the Cell address of the first cell of my data sort Column
Selection.End(xlDown).Select 'Get to the bottom Row of data
ActiveCell.Offset(-1, 0).Select
MySortCellEnd2 = ActiveCell.Address 'Get the Cell address of the last cell of my sort Column
'************************** Start the sort by specifying sort area and columns
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add _
Key:=Range(MySortCellStart2 & ":" & MySortCellEnd2), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range(MyDataFirstCell2 & ":" & MyDataLastCell2)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Select first element of first table
DoEvents
ActiveSheet.Range("F1").Select
Range(MyDataFirstCell).Select
End Sub
I am new at coding with VBA, I know languages like C and for LPC, but I have never learned VBA. So, any help of how to solve the problem or to improve my code, I'm all about it.
Thank you very much for your patience, attention and help.
You're code is really hard to follow - there's a good chance the wrong cell is selected at some point and you're subsequently trying to perform an illegal operation on the cell.
The code below will sort all the regions in your workbook by the second column (and will probably fail if any regions don't have a second column).
The important bit (other than the important bit I've highlighted in the code) is
Set rCurrentRegion = - this needs to be a reference to the range you're sorting.
It can be set manually using something like
Set rCurrentRegion = ThisWorkbook.Worksheets("Sheet1").Range("A10:Z5000").
In your code it would be
Set rCurrentRegion = Range(MySortCellStart2 & ":" & MySortCellEnd2) (although you're missing the worksheet reference - it will act on the activesheet otherwise).
Sub Test()
Dim Regions As Variant
Dim x As Long
Dim rCurrentRegion As Range
'Get a list of all the regions in your workbook as the range
'in your code doesn't appear to be in a static location.
'This will return an array of cell addresses.
'e.g. Regions(0) = "Sheet1!A4:P16"
' Regions(1) = "Sheet1!A21:L33"
Regions = FindRegionsInWorkbook(ThisWorkbook)
'Work through each element in the Regions array.
For x = LBound(Regions) To UBound(Regions)
'Turn the array element into a Range object.
Set rCurrentRegion = Range(Regions(x))
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'THIS IS THE IMPORTANT BIT '
'Sorting without selecting - the range that was '
'identified in the previous line of code is acted on. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The Parent of the range is the worksheet object.
With rCurrentRegion.Parent
.Sort.SortFields.Clear
'We're going to sort by the second column in the range.
.Sort.SortFields.Add _
Key:=rCurrentRegion.Columns(2), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
'Apply the sort.
With .Sort
.SetRange rCurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Next x
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This function returns all the separate regions in your workbook. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function FindRegionsInWorkbook(wrkBk As Workbook) As Variant
Dim ws As Worksheet, rRegion As Range, sRegion As String, sCheck As String
Dim sAddys As String, arrAddys() As String, aRegions() As Variant
Dim iCnt As Long, i As Long, j As Long
'//Cycle through each worksheet in workbook.
j = 0
For Each ws In wrkBk.Worksheets
sAddys = vbNullString
sRegion = vbNullString
On Error Resume Next
'//Find all ranges of constant & formula valies in worksheet.
sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
If Right(sAddys, 1) = "," Then sAddys = Left(sAddys, Len(sAddys) - 1)
On Error GoTo 0
If sAddys = vbNullString Then GoTo SkipWs
'//Put each seperate range into an array.
If InStr(1, sAddys, ",") = 0 Then
ReDim arrAddys(0 To 0)
arrAddys(0) = "'" & ws.Name & "'!" & sAddys
Else
arrAddys = Split(sAddys, ",")
For i = LBound(arrAddys) To UBound(arrAddys)
arrAddys(i) = "'" & ws.Name & "'!" & arrAddys(i)
Next i
End If
'//Place region that range sits in into sRegion (if not already in there).
For i = LBound(arrAddys) To UBound(arrAddys)
If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & "," '*** no sheet
sCheck = Right(arrAddys(i), Len(arrAddys(i)) - InStr(1, arrAddys(i), "!"))
ReDim Preserve aRegions(0 To j)
aRegions(j) = Left(arrAddys(i), InStr(1, arrAddys(i), "!") - 1) & "!" & ws.Range(sCheck).CurrentRegion.Address(0, 0)
j = j + 1
End If
Next i
SkipWs:
Next ws
On Error GoTo ErrHandle
FindRegionsInWorkbook = aRegions
Exit Function
ErrHandle:
'things you might want done if no lists were found...
End Function
I am trying to adapt some code that copies and pastes two separate ranges into another on a different sheet and then sorts it alphabetically. Problem is when i hide the sheet - even though I unhide and re-hide it to run the Macro - it seems to sort only on the Active Column.
I have singled out in bold the sorting code in the second macro below. The GetNamesList macro calls the ConsolidateList towards the end of its code.
The GetNamesList is set to run on workbook open:
Private Sub Workbook_Open()
GetNamesList
End Sub
The original code for GetNamesList is from: http://bit.ly/1y3dU6n by #Siddharth-rout
Sub GetNamesList()
Dim rng As Range, aCell As Range
Dim MyAr() As Variant
Dim n As Long, i As Long
Application.ScreenUpdating = False
Sheet28.Visible = True
'~~> Change this to the relevant sheet
With Sheet3
'~~> Non Contiguous range
Set rng = .Range("Table2[Contact 1],Table2[Contact 2]")
'~~> Get the count of cells in that range
n = rng.Cells.Count
'~~> Resize the array to hold the data
ReDim MyAr(1 To n)
n = 1
'~~> Store the values from that range into
'~~> the array
For Each aCell In rng.Cells
MyAr(n) = aCell.Value
n = n + 1
Next aCell
End With
'~~> Output the data in Sheet
'~~> Vertically Output to sheet 28
Sheet28.Cells(1, 1).Resize(UBound(MyAr), 1).Value = _
Application.WorksheetFunction.Transpose(MyAr)
ConsolidateList
Sheet28.Visible = False
Application.ScreenUpdating = True
End Sub
ConsolidateList is:
Sub ConsolidateList()
'
' ConsolidateList Macro
' Remove duplicates and blanks
'
With Sheet28.Range("A1:A1000")
.Value = .Value
.RemoveDuplicates Columns:=1, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
On Error GoTo 0
End With
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
End Sub
Thanks for your help...
**Update - recording of macro to do the same thing...
Sub TestSort()
'
' TestSort Macro
'
Sheets("Jan").Select
Sheets("Sheet1").Visible = True
ActiveWindow.SmallScroll Down:=-405
Range("A1:A134").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:A134")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-245
Sheets("Sheet1").Select
ActiveWindow.SelectedSheets.Visible = False
End Sub
Thanks #S-O. By taking your suggestion and puzzling over the recorded code I was able to cobble together the following:
Sub ConsolidateList()
'
' ConsolidateList Macro
' Remove duplicates and blanks
'
With Sheet28.Range("A1:A1000")
.Value = .Value
.RemoveDuplicates Columns:=1, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
On Error GoTo 0
End With
Sheet28.Sort.SortFields.Clear
Sheet28.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:A134")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Though an ActiveWorkbook seems to have snuck in there...!
**UPDATE
Replaced
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:A134")
With:
At top
Dim Lastrow As Integer
Then
Lastrow = Sheet28.Cells.Find("*", searchorder:=xlByRows,searchdirection:=xlPrevious).Row
With Sheet28.Sort
.SetRange Range("A1:A" & Lastrow)
That fixed it...
I created this macro to search through two spreadsheets and update one from the other based on unique keys that each row has. It will copy the first sheet to a temp sheet then unfilter and unhide everything. Next it will sort them by key so that they are all in order. after that it will move two columns to be excluded from the update to the front and update the rest. To update it will search through using the match function and if it comes up as an error (which means the row isn't there) it will add it to the end of the update sheet. Otherwise, it will copy and paste each row from the source to the update sheet. It all works but for some reason it won't update past line 24 and I have no idea why. I've stepped through it and it doesn't break, it just doesn't update. I am new to vba so any help would be greatly appreciated.
Sub crossUpdate()
Dim rng1 As Range, rng2 As Range, rng1Row As Range, rng2Row As Range, Key As Range, match As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim endRng2 As Long
Set wb2 = Workbooks("011 High Level Task List v2.xlsm")
Set wb1 = Workbooks("011 High Level Task List v2 ESI.xlsm")
'Unfilter and Unhide both sheets
With wb1.Sheets("Development Priority List")
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.AutoFilterMode = False
End With
With wb2.Sheets("Development Priority List")
.Cells.EntireColumn.Hidden = False
.Cells.EntireRow.Hidden = False
.AutoFilterMode = False
End With
'Copy and paste original sheet to new temp sheet
wb1.Sheets("Development Priority List").Activate
wb1.Sheets("Development Priority List").Cells.Select
Selection.Copy
Sheets.Add.Name = "SourceData"
wb1.Sheets("SourceData").Paste
N = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = wb1.Sheets("SourceData").Cells.Range("A2:A" & N)
Set rng1Row = rng1.EntireRow
'Sort temp sheet by key
wb1.Worksheets("SourceData").Sort.SortFields.Clear
wb1.Worksheets("SourceData").Sort.SortFields.Add Key:=wb1.Sheets("SourceData").Cells.Range("A2:A" & N), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With wb1.Worksheets("SourceData").Sort
.SetRange Range("A1:Z1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Sort update sheet by key
wb2.Activate
wb2.Worksheets("Development Priority List").Sort.SortFields.Clear
wb2.Worksheets("Development Priority List").Sort.SortFields.Add Key:=wb2.Sheets("Development Priority List").Cells.Range("A2:A" & N), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With wb2.Worksheets("Development Priority List").Sort
.SetRange Range("A1:Z1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Dev columns moved on SourceData sheet
wb1.Sheets("SourceData").Activate
Columns("F:G").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
'Dev columns moved on update sheet
wb2.Sheets("Development Priority List").Activate
Columns("F:G").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
'Update sheet searched and updated from SourceData
Set rng2 = wb2.Sheets("Development Priority List").Cells.Range("C2:C" & N)
endRng2 = rng2.Rows.Count
For i = 2 To rng1.Rows.Count + 1
Set Key = wb1.Sheets("SourceData").Range("C" & i)
match = Application.match(Key, rng2, 0)
'Rows that don't exsist in update sheet are added
If IsError(match) Then
wb1.Sheets("SourceData").Range("C" & i, "Z" & i).Copy
wb2.Sheets("Development Priority List").Range("C" & endRng2, "Z" & endRng2).Select
wb2.Sheets("Development Priority List").Paste
endRng2 = endRng2 + 1
'All other rows are scanned for changes
Else
For j = 3 To wb1.Sheets("SourceData").Range("C" & i, "Z" & i).Columns.Count
wb2.Sheets("Development Priority List").Cells(j, i).Value = wb1.Sheets("SourceData").Cells(j, i)
Next j
End If
Next i
'SourceData sheet deleted
Application.DisplayAlerts = False
wb1.Sheets("SourceData").Delete
Application.DisplayAlerts = True
'Dev columns moved back on update sheet
wb2.Sheets("Development Priority List").Activate
Columns("A:B").Select
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
wb1.Activate
It took me a few times coming back to this to figure out what was wrong. Here is what I believe is happening:
This code:
For j = 3 To wb1.Sheets("SourceData").Range("C" & i, "Z" & i).Columns.Count
wb2.Sheets("Development Priority List").Cells(j, i).Value = wb1.Sheets("SourceData").Cells(j, i)
Next j
Is looping from 3 to the number of columns between "C" and "Z" (ALWAYS 24). The bit inside the FOR loop is using Cells(<row>, <column>) syntax to copy from one cell to another. Because J is always looping from 3 to 24 then ROWS 3 through 24 are the only ones that will be updated. Perhaps you meant Cells(i,j)?