Want to have a static column referring to a dynamic range of data

[francozola25]

Hi i am wondering if someone could help me. I currently have a sheet called UPDATE_SHEET containing my data. When a Macro is run called UPDATE() what happens is, data is brought in from other worksheets (sched.xls). The data replaces current data from the range A:P. This data is dynamic and will change over time. What I want is column Q (COMMENTS heading) to have a summary for the row of information. This will be typed in. However when the Macro updates and new data is brought in I want to make sure the COMMENTS will be on the same row originally and will not be altered.

I have a primary key that is unique every time in column L called BARCODE #. The data in sched.xls will change from time to time and when this is copied over to UPDATE_SHEET, i want to make sure that data in COMMENTS column is referring to the same BARCODE # before and after the update.

Would anyone have any idea?

Please view code below


Sub UPDATE()
Application.DisplayAlerts = False
Sheets("UPDATE_SHEET").Select
Cells.Select
Selection.ClearContents
ChDir "T:\FinanceDept\WEEKLYFILES"
Sheets("UPDATE_SHEET").Select
Workbooks.Open Filename:= _
"T:\FinanceDept\WEEKLYFILES\sched.xls"
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows("CURRENT.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Windows("sched.xls").Activate
ActiveWorkbook.Close
Sheets("UPDATE_SHEET").Select
Range("A2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
ActiveCell.FormulaR1C1 = "NAME"
Range("B1").Select
ActiveCell.FormulaR1C1 = "DESCRIPTION"
Range("C1").Select
ActiveCell.FormulaR1C1 = "ORDER #"
Range("D1").Select
ActiveCell.FormulaR1C1 = "ORDER RELEASE DATE"
Range("E1").Select
ActiveCell.FormulaR1C1 = "ORDER DUE DATE"
Range("F1").Select
ActiveCell.FormulaR1C1 = "ORDER START DATE"
Range("G1").Select
ActiveCell.FormulaR1C1 = "ORDER FINISHED DATE"
Range("H1").Select
ActiveCell.FormulaR1C1 = "OPERATION #"
Range("I1").Select
ActiveCell.FormulaR1C1 = "OPERATION DESCRIPTION"
Range("J1").Select
ActiveCell.FormulaR1C1 = "OPERATION RELEASE DATE"
Range("K1").Select
ActiveCell.FormulaR1C1 = "OPERATION DUE DATE"
Range("L1").Select
ActiveCell.FormulaR1C1 = "BARCODE #"
Range("M1").Select
ActiveCell.FormulaR1C1 = "BARCODE STATUS"
Range("N1").Select
ActiveCell.FormulaR1C1 = "BARCODE AVAILABLE"
Range("O1").Select
ActiveCell.FormulaR1C1 = "BARCODE ON-HAND"
Range("P1").Select
ActiveCell.FormulaR1C1 = "BARCODE NOTE #"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "TEXT SUMMARY"
Range("A1:Q1").Select
Range("Q1").Activate
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
Selection.Font.Bold = True
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
Columns("A:Q").Select
Range("Q1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
ActiveWindow.DisplayZeros = False
Cells.Select
Cells.EntireColumn.AutoFit
Sheets("UPDATE_SHEET").Select
Columns("A:B").Select
Selection.Interior.ColorIndex = 35
Columns("C:J").Select
Columns("C:K").Select
Selection.Interior.ColorIndex = 6
Columns("L:Q").Select
Selection.Interior.ColorIndex = 40
Range("Q9").Select
Range("B1:Q1").Select
Selection.Interior.ColorIndex = xlNone
Range("A1").Select
Selection.Interior.ColorIndex = xlNone
Range("B10").Select
Application.CommandBars("Stop Recording").Visible = False
Application.DisplayAlerts = False
End sub

[rbrhodes]

Hi francoZ,

Try one of these on a COPY of your workbook. It's your macro (cleaned up from the recorder code) and with a dual array added to check the barcodes and comments

Ver 1 re-does the header rows (not neccesary i think) and ver 2 leaves the header rows alone (probably better) once the header rows are in place. Your choice - no noticable difference really.

Note: there is no errorhandling and macro's cannot be undone so use a COPY of your workbook to test this on.



Option Explicit
Sub UPDATEver1()

'Updates headers

Dim LastRow As Long
Dim ws As Worksheet
'Speed
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

'Create reference
Set ws = Sheets("UPDATE_SHEET")

'Employ
With ws
'Find last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Save barcodes
arrBar = .Range("L1:L" & LastRow)
'Save comments
ArrComm = .Range("Q1:Q" & LastRow)
'Set range object
Set rng = .Range("A2:Q" & LastRow)
'Employ
With rng
'Clear old
.ClearContents
'Clear borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
'Clear colour
.Interior.ColorIndex = xlNone
end With
'Open new data WB
'Workbooks.Open Filename:= _
"T:\FinanceDept\WEEKLYFILES\sched.xls"
Workbooks.Open Filename:= _
"c:\sched.xls"
'Copy all
Cells.Copy Destination:=ws.Range("A1")
'Close it
ActiveWorkbook.Close
'Put headers
.Range("A1") = "NAME"
.Range("B1") = "DESCRIPTION"
.Range("C1") = "ORDER #"
.Range("D1") = "ORDER RELEASE DATE"
.Range("E1") = "ORDER DUE DATE"
.Range("F1") = "ORDER START DATE"
.Range("G1") = "ORDER FINISHED DATE"
.Range("H1") = "OPERATION #"
.Range("I1") = "OPERATION DESCRIPTION"
.Range("J1") = "OPERATION RELEASE DATE"
.Range("K1") = "OPERATION DUE DATE"
.Range("L1") = "BARCODE #"
.Range("M1") = "BARCODE STATUS"
.Range("N1") = "BARCODE AVAILABLE"
.Range("O1") = "BARCODE ON-HAND"
.Range("P1") = "BARCODE NOTE #"
.Range("Q1") = "TEXT SUMMARY"
'Bold
.Range("A1:Q1").Font.Bold = True
'Get new last row of data (Col A)
LastRow = Range("A65536").End(xlUp).Row
'Set new range object
Set rng = .Range("L2:L" & LastRow)
'Restore comments (if any)
For Each cel In rng
For i = LBound(arrBar) To UBound(arrBar)
If cel.Value = arrBar(i, 1) Then
cel.Offset(0, 5) = ArrComm(i, 1)
Exit For
End If
Next i
Next cel
'Borders
.Range("A1:Q" & LastRow).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Colour
.Range("A1:B" & LastRow).Interior.ColorIndex = 35
.Range("C1:K" & LastRow).Interior.ColorIndex = 6
.Range("L1:Q" & LastRow).Interior.ColorIndex = 40
.Range("A1:Q1").Interior.ColorIndex = xlNone
'Fit
.Range("A1:P" & LastRow).EntireColumn.AutoFit
'Go home
.Range("A2").Select
End With
'Styff
With ActiveWindow
.DisplayZeros = False
.FreezePanes = True
End With

'Reset
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub




Sub UPDATEver2()

'Leaves headers

Dim arrBar
Dim ArrComm
Dim i As Long
Dim cel As Range
Dim rng As Range
Dim LastRow As Long
Dim ws As Worksheet
'Speed
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

'Create reference
Set ws = Sheets("UPDATE_SHEET")

'Employ
With ws
'Find last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Save barcodes
arrBar = .Range("L1:L" & LastRow)
'Save comments
ArrComm = .Range("Q1:Q" & LastRow)
'Set range object
Set rng = .Range("A2:Q" & LastRow)
'Employ
With rng
'Clear old
.ClearContents
'Clear borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
'Clear colour
.Interior.ColorIndex = xlNone
End With
'Open new data WB
'Workbooks.Open Filename:= _
"T:\FinanceDept\WEEKLYFILES\sched.xls"
Workbooks.Open Filename:= _
"c:\sched.xls"
'Get last row data (Col A)
LastRow = Range("A65536").End(xlUp).Row
'Copy all
Range("A2:P" & LastRow).Copy Destination:=.Range("A2")
'Close it
ActiveWorkbook.Close
'Get new last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Set new range object
Set rng = .Range("L2:L" & LastRow)
'Restore comments (if any)
For Each cel In rng
For i = LBound(arrBar) To UBound(arrBar)
If cel.Value = arrBar(i, 1) Then
cel.Offset(0, 5) = ArrComm(i, 1)
Exit For
End If
Next i
Next cel
'Borders
.Range("A1:Q" & LastRow).Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Colour
.Range("A1:B" & LastRow).Interior.ColorIndex = 35
.Range("C1:K" & LastRow).Interior.ColorIndex = 6
.Range("L1:Q" & LastRow).Interior.ColorIndex = 40
.Range("A1:Q1").Interior.ColorIndex = xlNone
'Fit
.Range("A1:P" & LastRow).EntireColumn.AutoFit


'Go home
.Range("A2").Select
End With
'Styff
With ActiveWindow
.DisplayZeros = False
.FreezePanes = True
End With

'Reset
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub

[francozola25]

Thanks for that

I am getting a Run-time error '1004':

Select method of Range class failed.

It is stopping at the following code.


.Range("A1:Q" & LastRow).Select

[francozola25]

You can ignore that last message. It is actually from A to Q and R is the Comments Field. I have changed the code from P to Q and from Q to R but it is bringing the text in R into Q.


Sub UPDATEver2()

'Leaves headers

Dim arrBar
Dim ArrComm
Dim i As Long
Dim cel As Range
Dim rng As Range
Dim LastRow As Long
Dim ws As Worksheet
'Speed
'With Application
' .DisplayAlerts = False
' .ScreenUpdating = False
'End With

'Create reference
Set ws = Sheets("LOTS_IN_Q")

'Employ
With ws
'Find last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Save barcodes
arrBar = .Range("L1:L" & LastRow)
'Save comments
ArrComm = .Range("R1:R" & LastRow)
'Set range object
Set rng = .Range("A2:R" & LastRow)
'Employ
With rng
'Clear old
.ClearContents
'Clear borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
'Clear colour
.Interior.ColorIndex = xlNone
End With
'Open new data WB
'Workbooks.Open Filename:= _
"T:\FinanceDept\WEEKLYFILES\sched.xls"
'Workbooks.Open Filename:= _
'"c:\sched.xls"
Workbooks.Open Filename:= _
"C:\shpsched3f.xls"
'Get last row data (Col A)
LastRow = Range("A65536").End(xlUp).Row
'Copy all
Range("A2:Q" & LastRow).Copy Destination:=.Range("A2")
'Close it
ActiveWorkbook.Close
'Get new last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Set new range object
Set rng = .Range("L2:L" & LastRow)
'Restore comments (if any)
For Each cel In rng
For i = LBound(arrBar) To UBound(arrBar)
If cel.Value = arrBar(i, 1) Then
cel.Offset(0, 5) = ArrComm(i, 1)
Exit For
End If
Next i
Next cel
'Borders
.Range("A1:R" & LastRow).Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Colour
.Range("A1:B" & LastRow).Interior.ColorIndex = 35
.Range("C1:K" & LastRow).Interior.ColorIndex = 6
.Range("L1:R" & LastRow).Interior.ColorIndex = 40
.Range("A1:R1").Interior.ColorIndex = xlNone
'Fit
.Range("A1:Q" & LastRow).EntireColumn.AutoFit


'Go home
.Range("A2").Select
End With
'Styff
' With ActiveWindow
' .DisplayZeros = False
' .FreezePanes = True
' End With

'Reset
'With Application
' .DisplayAlerts = True
' .ScreenUpdating = True
'End With

End Sub

[francozola25]

Brillant

You can ignore that last question as well. I had the offset set to 5 rather than 6.

It is working great now.

Many Thanks for all your help rbrhodes.

[rbrhodes]

Hi,

Glad to see you got it working! Perhaps time to add an error handler for those unexpected ones...

Also added code to clear memory of references.

Cheers, dr


Option Explicit
Sub UPDATEver2()

'Leaves headers

Dim arrBar
Dim ArrComm
Dim i As Long
Dim eMsg As Long
Dim cel As Range
Dim rng As Range
Dim LastRow As Long
Dim ws As Worksheet

'Handle errors
On Error GoTo endo

'Speed
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

'Create reference
Set ws = Sheets("LOTS_IN_Q")

'Employ
With ws
'Find last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Save barcodes
arrBar = .Range("L1:L" & LastRow)
'Save comments
ArrComm = .Range("R1:R" & LastRow)
'Set range object
Set rng = .Range("A2:R" & LastRow)
'Employ
With rng
'Clear old
.ClearContents
'Clear borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
'Clear colour
.Interior.ColorIndex = xlNone
End With
'Open new data WB
'Workbooks.Open Filename:= _
"T:\FinanceDept\WEEKLYFILES\sched.xls"
'Workbooks.Open Filename:= _
'"c:\sched.xls"
Workbooks.Open Filename:= _
"C:\shpsched3f.xls"
'Get last row data (Col A)
LastRow = Range("A65536").End(xlUp).Row
'Copy all
Range("A2:Q" & LastRow).Copy Destination:=.Range("A2")
'Close it
ActiveWorkbook.Close
'Get new last row of data (Col A)
LastRow = .Range("A65536").End(xlUp).Row
'Set new range object
Set rng = .Range("L2:L" & LastRow)
'Restore comments (if any)
For Each cel In rng
For i = LBound(arrBar) To UBound(arrBar)
If cel.Value = arrBar(i, 1) Then
cel.Offset(0, 5) = ArrComm(i, 1)
Exit For
End If
Next i
Next cel
'Borders
.Range("A1:R" & LastRow).Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Colour
.Range("A1:B" & LastRow).Interior.ColorIndex = 35
.Range("C1:K" & LastRow).Interior.ColorIndex = 6
.Range("L1:R" & LastRow).Interior.ColorIndex = 40
.Range("A1:R1").Interior.ColorIndex = xlNone
'Fit
.Range("A1:Q" & LastRow).EntireColumn.AutoFit

'Go home
.Range("A2").Select
End With

'Styff
With ActiveWindow
.DisplayZeros = False
.FreezePanes = True
End With

'Reset
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

'Destroy references
Set ws = Nothing
Set cel = Nothing
Set rng = Nothing
'Normal exit
Exit Sub
'Errored out
endo:
'Inform User
eMsg = MsgBox("Error number " & Err.Number & " " & Err.Description)

'Destroy references
Set ws = Nothing
Set cel = Nothing
Set rng = Nothing

'Reset
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub