Global PreviousID() As String 'Previous (before change) ID
Global CurrentID() As String 'Current (after change) ID
Public Const CellColor = 49407
Function FindColumn(ByVal data As String) As Integer 'Find Item in header row and give a column
xcol = ColumnLetter(Sheets("InputtedData").Cells(1, Sheets("InputtedData").Columns.Count).End(xlToLeft).Column)
Set res = Sheets("InputtedData").Range("A" & 1 & ":" & xcol & 1).Find(What:=data, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not res Is Nothing Then
FindColumn = res.Column
Else
FindColumn = 0
End If
End Function
Function FindRow(ByVal data As String, ByVal col As String, ByVal ws As String) As Long 'Find ID row in DataDump sheet
Sheets("InputtedData").AutoFilterMode = False
Sheets("InputtedData").Range("A1:" & col & 1).AutoFilter
Sheets("InputtedData").Range("A1:" & col & 1).AutoFilter _
Field:=1, Criteria1:="=" & data
Sheets("InputtedData").Range("A1:" & col & 1).AutoFilter _
Field:=2, Criteria1:="=" & ws
Sheets("InputtedData").Range("A1:" & col & 1).AutoFilter _
Field:=3, Criteria1:="=" & col
Dim rgAreas As Range
Dim rgArea As Range
Dim rgCell As Range
Set rgArea = Sheets("InputtedData").Range("A1:A10000").SpecialCells(xlCellTypeVisible)
For Each rgCell In rgArea.Cells
If Split(rgCell.Address, "$")(2) > 1 And Split(rgCell.Address, "$")(1) = "A" And rgCell.Value <> "" Then
FindRow = Split(rgCell.Address, "$")(2)
Sheets("InputtedData").AutoFilterMode = False
Exit Function
ElseIf Split(rgCell.Address, "$")(2) > 1 And Split(rgCell.Address, "$")(1) = "A" And rgCell.Value = "" Then
FindRow = 0
Sheets("InputtedData").AutoFilterMode = False
Exit Function
End If
Next rgCell
Set rgArea = Nothing
Sheets("InputtedData").AutoFilterMode = False
FindRow = 0
End Function
Sub Dump(ByVal id As String, ByVal sh As String) 'Writes data for specific ID into DataDump
On Error GoTo ExitSub
Dim aval As String
Dim dst_row As Integer
Dim dst_col As Integer
Dim item As String
Dim i As Long
If id = "" Then msgbox "No previous ID found. Please reopen": End 'If ID handler is blank
For i = 2 To Sheets(sh).Cells(65535, "B").End(xlUp).Row 'For each line
item = Sheets(sh).Cells(i, "B").Value 'Read item
If item <> "" Then 'And if this item is no blank row...
For k = 3 To Sheets(sh).Cells(i, _
Sheets(sh).Columns.Count).End(xlToLeft).Column 'For each column after 3 (C)
If Sheets(sh).Cells(i, k).Interior.Color = CellColor Then
aval = Sheets(sh).Cells(i, k).Value 'read value from C column
If aval <> "" Then
col = Split(Cells(1, k).Address, "$")(1) 'Convert column number to letter
dst_row = FindRow(id, col, sh) 'Get destination row for ID
If dst_row = 0 Then 'If there are NO entries...
dst_row = Sheets("InputtedData").Cells(65535, "A").End(xlUp).Row + 1 'Then add a line below last one
Sheets("InputtedData").Cells(dst_row, "A").Value = id 'Make a new entry for this ID
Sheets("InputtedData").Cells(dst_row, "B").Value = sh 'Make a new entry for this ID
Sheets("InputtedData").Cells(dst_row, "C").Value = col 'Make a new entry for this ID
End If
dst_col = FindColumn(item) 'Find column number by header
Sheets("InputtedData").Cells(dst_row, dst_col).NumberFormat = _
Sheets(sh).Cells(i, k).NumberFormat 'Keep number format
Sheets("InputtedData").Cells(dst_row, dst_col).Value = aval 'Save value
End If
End If
Next
End If
Next i
ExitSub:
End Sub
Sub Pop(ByVal id As String, ByVal sh As String) 'Reads data from DataDump to LoanSummary
'On Error GoTo ExitSub
Dim aval As String
Dim src_row As Long
Dim i As Long
Dim item As String
Dim src_col As Integer
For i = 2 To Sheets(sh).Cells(65535, "B").End(xlUp).Row 'For each line
item = Sheets(sh).Cells(i, "B").Value 'Read item
If item <> "" Then 'And if this item is no blank row...
src_col = FindColumn(item) 'Find column number by header
r = Sheets(sh).UsedRange.Columns.Count
For k = 3 To r 'For each column from 3
If Sheets(sh).Cells(i, k).Interior.Color = CellColor Then
col = Split(Cells(1, k).Address, "$")(1) 'Convert column number to letter
src_row = FindRow(id, col, sh) 'Get destination row for ID
If src_row <> 0 Then 'if entry was in Dump sheet..
aval = Sheets("InputtedData").Cells(src_row, _
src_col).Value 'Fill cells by values from dump
Else
aval = "" 'Else fill by blanks
End If
Sheets(sh).Cells(i, k).Value = aval 'Save value
End If
Next k
'Sheets("InputtedData").Cells(i, "C").NumberFormat = _
Sheets(sh).Cells(i, "C").NumberFormat 'Keep number format ()
End If
Next i
ExitSub:
End Sub
Function ColumnLetter(ColumnNumber As Integer) As String
If ColumnNumber > 26 Then
' 1st character: Subtract 1 to map the characters to 0-25,
' but you don't have to remap back to 1-26
' after the 'Int' operation since columns
' 1-26 have no prefix letter
' 2nd character: Subtract 1 to map the characters to 0-25,
' but then must remap back to 1-26 after
' the 'Mod' operation by adding 1 back in
' (included in the '65')
ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
Chr(((ColumnNumber - 1) Mod 26) + 65)
Else
' Columns A-Z
ColumnLetter = Chr(ColumnNumber + 64)
End If
End Function
and here is code in sheet again for your reference:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error GoTo 0
If Target.Column = 2 And Target.Row = 1 Then 'Target cell with Loan ID
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ReDim Preserve CurrentID(Sheets.Count)
CurrentID(Target.Worksheet.Index) = Target 'Refers to global CurrentID
'----------DUMP-------------
Dump PreviousID(Target.Worksheet.Index), _
Target.Worksheet.Name 'Dump previous ID Data
'---------POPUP-------------
Pop CurrentID(Target.Worksheet.Index), _
Target.Worksheet.Name 'Populate current data
'---------------------------
ReDim Preserve PreviousID(Sheets.Count)
PreviousID(Target.Worksheet.Index) = _
CurrentID(Target.Worksheet.Index) 'Refers to global PreviousID
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks