3个合并单元格，如何直接读另外两个合并单元格数据？

ning84 · 发表于 2024-7-12 12:02

Sub ll()
Dim Rng As Range, oRng As Range
Set Rng = Selection.CurrentRegion
Debug.Print Rng.Address
For ii = 1 To Rng.Rows.Count
For jj = 1 To 3
Set oRng = Rng(ii, jj)
Debug.Print oRng.Address, ismerge, oRng.MergeArea.Rows.Count, oRng.MergeArea.Address
Next jj
If oRng.MergeArea.Count > 1 Then
ii = ii + oRng.MergeArea.Count
End If
Stop
Next ii
Stop
End Sub

复制代码

结果

$A$4:$D$112
$A$4                      1          $A$4
$B$4                      1          $B$4
$C$4                      1          $C$4
$A$5                      32          $A$5:$A$36
$B$5                      7          $B$5:$B$11
$C$5                      1          $C$5
$A$6                      32          $A$5:$A$36
$B$6                      7          $B$5:$B$11
$C$6                      2          $C$6:$C$7

*****************************************************

例如，
for next c列 Rang(C24:C25),
直接读B列的B12数值
直接读A列的A5数值

longwin · 发表于 2024-7-12 15:44

Sub test()
dz = "$B$25"
With Sheet1
If .Range(dz).MergeCells Then
Debug.Print .Range(dz).MergeArea.Cells(1, 1).Value
End If
End With

longwin · 发表于 2024-7-12 15:50

蓝桥玄霜 · 发表于 2024-7-12 16:04

AB列的例子：

ning84 · 发表于 2024-7-12 17:53

longwin 发表于 2024-7-12 15:50

谢谢回复。我用得是MergeArea.Count > 1,忘记了以前学过的oRng.MergeCells

优化程序，目标实现。

Sub ll()
Dim Fso As FileSystemObject
Set Fso = New FileSystemObject
Dim oFolder As Folder
Dim Sht As Worksheet
Dim Str, oStr, oPath
Dim Rng As Range, oRng As Range
Set Rng = Selection
Set Sht = Rng.Parent
Set Rng = Sht.Cells(10, 1).CurrentRegion
Dim RootName
RootName = Sht.Cells(1, 1)
Debug.Print Rng.Address
For jj = 1 To 3
For ii = 1 To Rng.Rows.Count
Set oRng = Rng(ii, jj)
If oRng.MergeCells Then 'MergeArea.Count > 1 Then
Set oRng = oRng.MergeArea
ii = ii + oRng.Count
End If
Select Case jj
Case 1
oStr = Format(oRng(, "D"), "yyyy年")
oPath = RootName & Format(oRng(, "D"), "yyyy年") & ""
Case 2
oStr = Format(Sht.Cells(oRng.Row, "D"), "yyyy年mm月")
oPath = RootName & Format(oRng(, "D"), "yyyy年") & "" & Format(oRng(, "D"), "yyyy年mm月") & ""
Case 3
oStr = Format(Sht.Cells(oRng.Row, "D"), "yyyy年mm月dd日")
oPath = RootName & Format(oRng(, "D"), "yyyy年") & "" & Format(oRng(, "D"), "yyyy年mm月") & "" & Format(oRng(, "D"), "yyyy年mm月dd日") & ""
End Select
Set oFolder = Fso.GetFolder(oPath)
With oFolder
Debug.Print oRng.Address, oStr, .Path, .SubFolders.Count, .Files.Count, .IsRootFolder, .Type
oRng = oStr & Chr(10) & "SubFolder Num:" & .SubFolders.Count '& Chr(10) & "Files Num:" & .Files.Count
End With
Next ii
Next jj
Stop
End Sub

复制代码

ning84 · 发表于 2024-7-14 01:58

本帖最后由 ning84 于 2024-7-14 06:45 编辑

ning84 发表于 2024-7-12 17:53
谢谢回复。我用得是MergeArea.Count > 1,忘记了以前学过的oRng.MergeCells

优化程序，目标实现。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Rng As Range
Set Rng = Selection
Dim Sht As Worksheet
Set Sht = Rng.Parent
With Sht
Rng = Selection
If Rng.Column <= 8 Then
Set Rng = .Cells(Rng.Row, "H")
ElseIf Rng.Column = 9 Then
Set Rng = .Cells(Rng.Row, "J")
Else
Set Rng = .Cells(Rng.Row, Rng.Column)
End If
Debug.Print Rng.Address
Rng.Hyperlinks.Add Rng, Rng
End With
End Sub
Sub llll()
Dim Fso As FileSystemObject
Set Fso = New FileSystemObject
Dim Rng As Range, oRng As Range, oRng1 As Range
Set Rng = Selection
Dim Sht As Worksheet
Dim oFile As File
Dim oFolder1 As Folder, oFolder2 As Folder, oFolder3 As Folder
Dim oSize
Set Sht = Rng.Parent
With Sht
Set Rng = .Range(.Cells(4, 1).Formula)
End With
Debug.Print Rng.Address
For jj = 1 To 3
For ii = 3 To Rng.Rows.Count
Set oRng = Rng(ii, jj)
If oRng.MergeCells Then
Set oRng = oRng.MergeArea
'Debug.Print oRng.Address, oRng(1, 1).Address, oRng(, "H")
With Sht
oStr = .Cells(oRng(, 1).Row, "H")
End With
Set oFile = Fso.GetFile(oStr)
Set oFolder3 = oFile.ParentFolder
Set oFolder2 = oFolder3.ParentFolder
Set oFolder1 = oFolder2.ParentFolder
Select Case jj
Case 1
Set oRng1 = Sht.Cells(oRng(, 1).Row, "F").Resize(oRng.Rows.Count, 1)
oSize = WorksheetFunction.Sum(oRng1)
oRng(, 1) = oFolder1.Name & Chr(10) & "SubFolder" & oFolder1.SubFolders.Count & Chr(10) & "Files:" & oRng.Rows.Count & Chr(10) & "Size:" & oSize & "MB"
Case 2
Set oRng1 = Sht.Cells(oRng(, 1).Row, "F").Resize(oRng.Rows.Count, 1)
oSize = WorksheetFunction.Sum(oRng1)
oRng(, 1) = oFolder2.Name & Chr(10) & "SubFolder" & oFolder2.SubFolders.Count & Chr(10) & "Files:" & oRng.Rows.Count & Chr(10) & "Size:" & oSize & "MB"
Case 3
Set oRng1 = Sht.Cells(oRng(, 1).Row, "F").Resize(oRng.Rows.Count, 1)
oSize = WorksheetFunction.Sum(oRng1)
oRng(, 1) = oFolder3.Name & Chr(10) & "Files:" & oRng.Rows.Count & Chr(10) & "Size:" & oSize & "MB"
End Select
'Debug.Print oFolder1.Path, oFolder2.Path, oFolder3.Path
ii = ii + oRng.Rows.Count
End If
Next ii
Next jj
End Sub

复制代码

Function MergeRng(Rng As Range)
Dim LastRow, FirstRow
Dim ii, jj
Dim Sht As Worksheet
Set Sht = Rng.Parent
With Rng.Parent
LastRow = Rng.Row + Rng.Rows.Count - 1
For ii = Rng.Row + Rng.Rows.Count - 1 To 2 Step -1
If .Cells(ii, Rng.Column).Value <> .Cells(ii - 1, Rng.Column).Value Then
FirstRow = ii
If FirstRow < Rng.Row Then
Exit Function
End If
.Cells(FirstRow, Rng.Column).Resize(LastRow - FirstRow + 1, 1).Merge
LastRow = ii - 1
End If
Next ii
End With
End Function
''
Function MergeRetuFolderFile(Fso As FileSystemObject, Rng As Range)
Dim Sht As Worksheet
Set Sht = Rng.Parent
Dim oFile As File
Dim oFolder1 As Folder, oFolder2 As Folder, oFolder3 As Folder
Dim oSize
Dim oRng As Range, oRng1 As Range
For jj = 1 To 3
For ii = 1 To Rng.Rows.Count
Set oRng = Rng(ii, jj)
If oRng.MergeCells Then
Set oRng = oRng.MergeArea
'Debug.Print oRng.Address, oRng(1, 1).Address, oRng(, "H")
With Sht
oStr = .Cells(oRng(, 1).Row, "H")
End With
Set oFile = Fso.GetFile(oStr)
Set oFolder3 = oFile.ParentFolder
Set oFolder2 = oFolder3.ParentFolder
Set oFolder1 = oFolder2.ParentFolder
Select Case jj
Case 1
Set oRng1 = Sht.Cells(oRng(, 1).Row, "F").Resize(oRng.Rows.Count, 1)
oSize = WorksheetFunction.Sum(oRng1)
oRng(, 1) = oFolder1.Name & Chr(10) & "SubFolder" & oFolder1.SubFolders.Count & Chr(10) & "Files:" & oRng.Rows.Count & Chr(10) & "Size:" & oSize & "MB"
Case 2
Set oRng1 = Sht.Cells(oRng(, 1).Row, "F").Resize(oRng.Rows.Count, 1)
oSize = WorksheetFunction.Sum(oRng1)
oRng(, 1) = oFolder2.Name & Chr(10) & "SubFolder" & oFolder2.SubFolders.Count & Chr(10) & "Files:" & oRng.Rows.Count & Chr(10) & "Size:" & oSize & "MB"
Case 3
Set oRng1 = Sht.Cells(oRng(, 1).Row, "F").Resize(oRng.Rows.Count, 1)
oSize = WorksheetFunction.Sum(oRng1)
oRng(, 1) = oFolder3.Name & Chr(10) & "Files:" & oRng.Rows.Count & Chr(10) & "Size:" & oSize & "MB"
End Select
'Debug.Print oFolder1.Path, oFolder2.Path, oFolder3.Path
ii = ii + oRng.Rows.Count
End If
Next ii
Next jj
End Function

复制代码

		自动登录	找回密码
密码			免费注册