|
Hallo,
auf dern Basis dieses SourceCodes wurde folgendes Beispiel generiert:
Userform "frmCompare"
Combobox "cbxMap1" // Textbox "txtRange1" // CommandButton "cmdSelect1"
Combobox "cbxMap2" // Textbox "txtRange2" // CommandButton "cmdSelect2"
CommandButton "cmdCompare"
Option Explicit
Private Sub cmdCompare_Click()
Call CompareRanges(Me.txtRange1.value, Me.txtRange2.value)
End Sub
Private Sub cmdSelect1_Click()
If nz(Me.cbxMap1.value, "") = "" Then
MsgBox "Wähle zuerst eine Arbeitsmappe aus.", vbInformation
Else
Application.Workbooks(Me.cbxMap1.value).Activate
Me.Hide
With frmDoSelect
.lbInfo.Caption = "Markiere einen Bereich mit den zu vergleichenden Inhalten."
.lblTransfer.Caption = "1"
.Show (False)
End With
End If
End Sub
Private Sub cmdSelect2_Click()
If nz(Me.cbxMap2.value, "") = "" Then
MsgBox "Wähle zuerst eine Arbeitsmappe aus.", vbInformation
Else
Application.Workbooks(Me.cbxMap2.value).Activate
Me.Hide
With frmDoSelect
.lbInfo.Caption = "Markiere einen Bereich mit den zu vergleichenden Inhalten."
.lblTransfer.Caption = "2"
.Show (False)
End With
End If
End Sub
Private Sub UserForm_Initialize()
FillComboBoxMaps cbx:=Me.cbxMap1
FillComboBoxMaps cbx:=Me.cbxMap2
End Sub
Sub FillComboBoxMaps(cbx As ComboBox)
Dim Workbk() As String
Dim bk As Workbook
Dim iBk As Integer
For Each bk In Application.Workbooks
ReDim Preserve Workbk(iBk)
Workbk(iBk) = bk.Name
iBk = iBk + 1
Next
cbx.List = Workbk
End Sub
UserForm "frmDoSelect"
label: "lbInfo" // Label "lblCell" // Label: "lblTransfer" (unsichtbar)
Commandbutton: "cmdOK"
Option Explicit
Private Sub cmdOK_Click()
Dim rng As Range
Set rng = Selection
Call getActiveRange
Select Case Me.lblTransfer.Caption
Case "1"
frmCompare.txtRange1.value = lblCell.Caption
Case "2"
frmCompare.txtRange2.value = lblCell.Caption
Case Else
End Select
frmCompare.Show (False)
Unload Me
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
getActiveRange
End Sub
Sub getActiveRange()
Dim rng As Range, strEnd As String
Dim bk As Workbook
Set bk = ActiveWorkbook
Set rng = Application.ActiveCell
strEnd = Selection.SpecialCells(xlCellTypeLastCell).Address
Me.lblCell.Caption = "[" & bk.Name & "]" & rng.Worksheet.Name & "!" & rng.Address & IIf(rng.Address <> strEnd, ":" & strEnd, "")
End Sub
Modul modFuncs
Option Explicit
Public Function nz(value As Variant, replace As Variant) As Variant
If IsNull(value) Then
nz = replace
Else
nz = value
End If
End Function
Sub CompareRanges(strSrc As String, strDest As String)
Dim rngSrc As Range
Dim rngDest As Range
Dim iCl As Integer, iRw As Integer
Dim strValSrc As String, strValDest As String
If nz(strSrc, "") <> "" And nz(strDest, "") <> "" Then
Set rngSrc = Range(strSrc)
Set rngDest = Range(strDest)
If Not (rngSrc.Rows.Count = rngDest.Rows.Count And rngSrc.Columns.Count = rngDest.Columns.Count) Then
MsgBox "Die zu vergleichende Bereiche sind unterschiedlich groß"
Else
For iRw = 1 To rngSrc.Rows.Count
For iCl = 1 To rngSrc.Columns.Count
If rngSrc.Cells(iRw, iCl).value = rngDest.Cells(iRw, iCl).value Then
rngDest.Cells(iRw, iCl).Interior.Color = vbRed
End If
Next
Next
End If
End If
End Sub
Mit dem Aufruf der Userform "frmCompare" wird ein Vergleich gestartet.
VG, BigBen
|