Imaginativeone
New Member
- Joined
- Mar 6, 2008
- Messages
- 9
My Function "FindMoves" (in red) creates two sets of 129 rows of named ranges. One of these range-sets resides on Sheet1 and the other on Sheet2. Is there a way that I can compare the named ranges on the respective sheets?
Thanks
Option Explicit
Private Sub cmdCompare_Click()
Dim excelApp
Set excelApp = CreateObject("Excel.Application")
UseMatchFunction excelApp
FindAddsNDrops excelApp
FindMoves excelApp, "Sheet1", "Sheet2"
End Sub
Function UseMatchFunction(excelApp)
Application.ScreenUpdating = False
' Dim wordApp
' Set wordApp = CreateObject("Word.Application")
' wordApp.Visible = True
' wordApp.Documents.Add
excelApp.Visible = True
excelApp.Workbooks.Add
Dim pWorkbook As Workbook
Dim pWorksheet As Worksheet
Dim pTabName As String: pTabName = "OASDI 2007"
Dim pListColumn As Range
Dim pListColumnVolume As Integer
Set pWorkbook = ActiveWorkbook
Set pWorksheet = pWorkbook.Sheets(pTabName)
Set pListColumn = pWorksheet.Range("A1").SpecialCells(xlCellTypeLastCell)
pListColumnVolume = pListColumn.row
Dim pCellPosValue As New DynamicArray
Dim pCellLocation
Dim pCellContents
Dim pCellFunction
Dim pCellAddress
Dim pListInputRowIndex: pListInputRowIndex = 6
Dim pListOutputRowIndex: pListOutputRowIndex = 2
' Dim pListOutputColIndex: pListOutputColIndex = -1
Dim pListOutputColIndex: pListOutputColIndex = 0
' ////////////////////////////////////////////////////////////////////////////////////
Do Until pListInputRowIndex > pListColumnVolume
Set pCellLocation = pWorksheet.Cells(pListInputRowIndex, 1)
pCellContents = pWorksheet.Cells(pListInputRowIndex, 1).Value
If Not IsNumeric(pCellContents) Then
pListOutputColIndex = pListOutputColIndex + 1
' pListOutputColIndex = pListOutputColIndex + 2
pListOutputRowIndex = 2
excelApp.Cells(pListOutputColIndex, 1).Value = pCellContents
Else
excelApp.Cells(pListOutputColIndex, pListOutputRowIndex).Value = pCellContents
pListOutputRowIndex = pListOutputRowIndex + 1
End If
pListInputRowIndex = pListInputRowIndex + 1
Loop
' ////////////////////////////////////////////////////////////////////////////////////
excelApp.Sheets("Sheet2").Select
Dim cWorkbook As Workbook
Dim cWorksheet As Worksheet
Dim cTabName As String: cTabName = "OASDI 2008"
Dim cListColumn As Range
Dim cListColumnVolume As Integer
Set cWorkbook = ActiveWorkbook
Set cWorksheet = cWorkbook.Sheets(cTabName)
Set cListColumn = cWorksheet.Range("A1").SpecialCells(xlCellTypeLastCell)
cListColumnVolume = cListColumn.row
Dim cCellPosValue As New DynamicArray
Dim cCellLocation
Dim cCellContents
Dim cCellFunction
Dim cCellAddress
Dim cListInputRowIndex: cListInputRowIndex = 6
Dim cListOutputRowIndex: cListOutputRowIndex = 2
Dim cListOutputColIndex: cListOutputColIndex = 0
' ////////////////////////////////////////////////////////////////////////////////////
Do Until cListInputRowIndex > cListColumnVolume
Set cCellLocation = cWorksheet.Cells(cListInputRowIndex, 1)
cCellContents = cWorksheet.Cells(cListInputRowIndex, 1).Value
If Not IsNumeric(cCellContents) Then
cListOutputColIndex = cListOutputColIndex + 1
' cListOutputColIndex = cListOutputColIndex + 2
cListOutputRowIndex = 2
excelApp.Cells(cListOutputColIndex, 1).Value = cCellContents
Else
excelApp.Cells(cListOutputColIndex, cListOutputRowIndex).Value = cCellContents
cListOutputRowIndex = cListOutputRowIndex + 1
End If
cListInputRowIndex = cListInputRowIndex + 1
Loop
' ////////////////////////////////////////////////////////////////////////////////////
End Function
Sub FindAddsNDrops(excelApp)
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim c As Range
Dim rng As Range
' Set rng1 = Sheets(1).UsedRange
' Set rng2 = Sheets(2).UsedRange
Set rng1 = excelApp.Sheets(1).UsedRange
Set rng2 = excelApp.Sheets(2).UsedRange
' Adds and Drops (moves are in a different function)
For Each cell In rng1
If cell <> "" Then
Set c = rng2.Find(cell, lookat:=xlWhole)
If c Is Nothing Then
cell.Interior.ColorIndex = 3
End If
End If
Next cell
For Each cell In rng2
If cell <> "" Then
Set c = rng1.Find(cell, lookat:=xlWhole)
If c Is Nothing Then
cell.Interior.ColorIndex = 3
End If
End If
Next cell
End Sub
Function FindMoves(excelApp, pTabName, cTabName)
excelApp.Worksheets(pTabName).Select
Dim used_Rows, rowVolume
Set used_Rows = excelApp.Sheets(pTabName).Range("A1").SpecialCells(xlCellTypeLastCell)
rowVolume = used_Rows.row
Dim pRangeNameArray As New DynamicArray
Dim comparisonRange As Range
Dim cleanedName
Dim r
For r = 1 To rowVolume
Set comparisonRange = excelApp.Range(excelApp.Cells(r, 1), excelApp.Cells(r, 1).End(xlToRight))
cleanedName = excelApp.Cells(r, 1).Value & "_2008"
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, ",", "_")
cleanedName = Replace(cleanedName, ".", "_")
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, "__", "_")
comparisonRange.Name = cleanedName
comparisonRange.Select
pRangeNameArray.Data(r) = cleanedName
Next
excelApp.Worksheets(cTabName).Select
' Dim used_Rows, rowVolume
Set used_Rows = excelApp.Sheets(cTabName).Range("A1").SpecialCells(xlCellTypeLastCell)
rowVolume = used_Rows.row
Dim cRangeNameArray As New DynamicArray
' Dim comparisonRange As Range
' Dim cleanedName
' Dim r
For r = 1 To rowVolume
Set comparisonRange = excelApp.Range(excelApp.Cells(r, 1), excelApp.Cells(r, 1).End(xlToRight))
cleanedName = excelApp.Cells(r, 1).Value & "_2008"
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, ",", "_")
cleanedName = Replace(cleanedName, ".", "_")
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, "__", "_")
comparisonRange.Name = cleanedName
comparisonRange.Select
cRangeNameArray.Data(r) = cleanedName
Next
MsgBox UBound(pRangeNameArray.DataArray)
MsgBox UBound(cRangeNameArray.DataArray)
End Function
Function LastInRow(rng As Range)
Application.Volatile
With rng.Parent
With .Cells(rng.row, .Columns.Count)
If Not IsEmpty(.Value) Then
LastInRow = .Value
ElseIf IsEmpty(.End(xlToLeft)) Then
LastInRow = ""
Else
LastInRow = .End(xlToLeft).Value
End If
End With
End With
End Function
Function CompareMoves(pRows, cRows)
End Function
' pCellPosValue.Data(pListRowIndex) = Excel.WorksheetFunction.Match(pCellContents, [A:A], 0)
Private Sub UserForm_Click()
End Sub
Thanks
Option Explicit
Private Sub cmdCompare_Click()
Dim excelApp
Set excelApp = CreateObject("Excel.Application")
UseMatchFunction excelApp
FindAddsNDrops excelApp
FindMoves excelApp, "Sheet1", "Sheet2"
End Sub
Function UseMatchFunction(excelApp)
Application.ScreenUpdating = False
' Dim wordApp
' Set wordApp = CreateObject("Word.Application")
' wordApp.Visible = True
' wordApp.Documents.Add
excelApp.Visible = True
excelApp.Workbooks.Add
Dim pWorkbook As Workbook
Dim pWorksheet As Worksheet
Dim pTabName As String: pTabName = "OASDI 2007"
Dim pListColumn As Range
Dim pListColumnVolume As Integer
Set pWorkbook = ActiveWorkbook
Set pWorksheet = pWorkbook.Sheets(pTabName)
Set pListColumn = pWorksheet.Range("A1").SpecialCells(xlCellTypeLastCell)
pListColumnVolume = pListColumn.row
Dim pCellPosValue As New DynamicArray
Dim pCellLocation
Dim pCellContents
Dim pCellFunction
Dim pCellAddress
Dim pListInputRowIndex: pListInputRowIndex = 6
Dim pListOutputRowIndex: pListOutputRowIndex = 2
' Dim pListOutputColIndex: pListOutputColIndex = -1
Dim pListOutputColIndex: pListOutputColIndex = 0
' ////////////////////////////////////////////////////////////////////////////////////
Do Until pListInputRowIndex > pListColumnVolume
Set pCellLocation = pWorksheet.Cells(pListInputRowIndex, 1)
pCellContents = pWorksheet.Cells(pListInputRowIndex, 1).Value
If Not IsNumeric(pCellContents) Then
pListOutputColIndex = pListOutputColIndex + 1
' pListOutputColIndex = pListOutputColIndex + 2
pListOutputRowIndex = 2
excelApp.Cells(pListOutputColIndex, 1).Value = pCellContents
Else
excelApp.Cells(pListOutputColIndex, pListOutputRowIndex).Value = pCellContents
pListOutputRowIndex = pListOutputRowIndex + 1
End If
pListInputRowIndex = pListInputRowIndex + 1
Loop
' ////////////////////////////////////////////////////////////////////////////////////
excelApp.Sheets("Sheet2").Select
Dim cWorkbook As Workbook
Dim cWorksheet As Worksheet
Dim cTabName As String: cTabName = "OASDI 2008"
Dim cListColumn As Range
Dim cListColumnVolume As Integer
Set cWorkbook = ActiveWorkbook
Set cWorksheet = cWorkbook.Sheets(cTabName)
Set cListColumn = cWorksheet.Range("A1").SpecialCells(xlCellTypeLastCell)
cListColumnVolume = cListColumn.row
Dim cCellPosValue As New DynamicArray
Dim cCellLocation
Dim cCellContents
Dim cCellFunction
Dim cCellAddress
Dim cListInputRowIndex: cListInputRowIndex = 6
Dim cListOutputRowIndex: cListOutputRowIndex = 2
Dim cListOutputColIndex: cListOutputColIndex = 0
' ////////////////////////////////////////////////////////////////////////////////////
Do Until cListInputRowIndex > cListColumnVolume
Set cCellLocation = cWorksheet.Cells(cListInputRowIndex, 1)
cCellContents = cWorksheet.Cells(cListInputRowIndex, 1).Value
If Not IsNumeric(cCellContents) Then
cListOutputColIndex = cListOutputColIndex + 1
' cListOutputColIndex = cListOutputColIndex + 2
cListOutputRowIndex = 2
excelApp.Cells(cListOutputColIndex, 1).Value = cCellContents
Else
excelApp.Cells(cListOutputColIndex, cListOutputRowIndex).Value = cCellContents
cListOutputRowIndex = cListOutputRowIndex + 1
End If
cListInputRowIndex = cListInputRowIndex + 1
Loop
' ////////////////////////////////////////////////////////////////////////////////////
End Function
Sub FindAddsNDrops(excelApp)
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim c As Range
Dim rng As Range
' Set rng1 = Sheets(1).UsedRange
' Set rng2 = Sheets(2).UsedRange
Set rng1 = excelApp.Sheets(1).UsedRange
Set rng2 = excelApp.Sheets(2).UsedRange
' Adds and Drops (moves are in a different function)
For Each cell In rng1
If cell <> "" Then
Set c = rng2.Find(cell, lookat:=xlWhole)
If c Is Nothing Then
cell.Interior.ColorIndex = 3
End If
End If
Next cell
For Each cell In rng2
If cell <> "" Then
Set c = rng1.Find(cell, lookat:=xlWhole)
If c Is Nothing Then
cell.Interior.ColorIndex = 3
End If
End If
Next cell
End Sub
Function FindMoves(excelApp, pTabName, cTabName)
excelApp.Worksheets(pTabName).Select
Dim used_Rows, rowVolume
Set used_Rows = excelApp.Sheets(pTabName).Range("A1").SpecialCells(xlCellTypeLastCell)
rowVolume = used_Rows.row
Dim pRangeNameArray As New DynamicArray
Dim comparisonRange As Range
Dim cleanedName
Dim r
For r = 1 To rowVolume
Set comparisonRange = excelApp.Range(excelApp.Cells(r, 1), excelApp.Cells(r, 1).End(xlToRight))
cleanedName = excelApp.Cells(r, 1).Value & "_2008"
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, ",", "_")
cleanedName = Replace(cleanedName, ".", "_")
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, "__", "_")
comparisonRange.Name = cleanedName
comparisonRange.Select
pRangeNameArray.Data(r) = cleanedName
Next
excelApp.Worksheets(cTabName).Select
' Dim used_Rows, rowVolume
Set used_Rows = excelApp.Sheets(cTabName).Range("A1").SpecialCells(xlCellTypeLastCell)
rowVolume = used_Rows.row
Dim cRangeNameArray As New DynamicArray
' Dim comparisonRange As Range
' Dim cleanedName
' Dim r
For r = 1 To rowVolume
Set comparisonRange = excelApp.Range(excelApp.Cells(r, 1), excelApp.Cells(r, 1).End(xlToRight))
cleanedName = excelApp.Cells(r, 1).Value & "_2008"
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, ",", "_")
cleanedName = Replace(cleanedName, ".", "_")
cleanedName = Replace(cleanedName, " ", "_")
cleanedName = Replace(cleanedName, "__", "_")
comparisonRange.Name = cleanedName
comparisonRange.Select
cRangeNameArray.Data(r) = cleanedName
Next
MsgBox UBound(pRangeNameArray.DataArray)
MsgBox UBound(cRangeNameArray.DataArray)
End Function
Function LastInRow(rng As Range)
Application.Volatile
With rng.Parent
With .Cells(rng.row, .Columns.Count)
If Not IsEmpty(.Value) Then
LastInRow = .Value
ElseIf IsEmpty(.End(xlToLeft)) Then
LastInRow = ""
Else
LastInRow = .End(xlToLeft).Value
End If
End With
End With
End Function
Function CompareMoves(pRows, cRows)
End Function
' pCellPosValue.Data(pListRowIndex) = Excel.WorksheetFunction.Match(pCellContents, [A:A], 0)
Private Sub UserForm_Click()
End Sub