统计VBA学习小组正式组第九课（第十一讲）的积分帖之作业上交贴（第12周） - 第2页 - Excel VBA实战营2期 - Excel精英培训网

chenzhi_juan 发表于 2012-3-15 22:33

Sub selects()

Dim rg As Range, x As Integer, a As Integer

a = 0

For x = 2 To 11

   If Cells(x, "d") > 20 Then

   a = a + 1

      If a = 1 Then

         Set rg = Rows(x)

         Else

      Set rg = Union(Rows(x), rg)

      End If

   End If

Next

rg.Select

End Sub

byhdch 发表于 2012-3-15 22:58

A09:byhdch
方法1
Sub 同时选取金额大于20的行1()
Sheets("sheet3").Select
Dim rg As Range, i As Integer
   For i = 2 To Range("d65536").End(xlUp).Row
   If Cells(i, 4).Value > 20 Then
         If rg Is Nothing Then
         Set rg = Rows(i)
   Else
      Set rg = Union(rg, Rows(i))
         End If
   End If
Next i
rg.Select
End Sub

方法2
Sub 同时选取金额大于20的行2()
Sheets("sheet3").Select
Dim rg As Range, i As Integer
   For i = 2 To Range("d65536").End(xlUp).Row
   If Range("d" & i).Value > 20 Then
         If rg Is Nothing Then
         Set rg = Range("d" & i)
   Else
         Set rg = Union(rg, Range("d" & i))
         End If
   End If
Next i
rg.EntireRow.Select
End Sub

方法3
Sub 同时选取金额大于20的行3()
Sheets("sheet3").Select
Dim rg As Range, i As Integer
   For i = 2 To Range("d65536").End(xlUp).Row
   If Cells(i, 4).Value > 20 Then
         If rg Is Nothing Then
         Set rg = Cells(i, 4)
   Else
      Set rg = Union(rg, Cells(i, 4))
         End If
   End If
Next i
rg.EntireRow.Select
End Sub

jxncfxsf 发表于 2012-3-16 11:44

21组 ID号：jxncfxsf
Sub 选取符合条件的单元格1()
Dim x, y As Long
Dim st As String
For x = 2 To Range("d" & Rows.Count).End(xlUp).Row
If Cells(x, 4).Value > 20 Then
st = st & x & ":"
For y = x + 1 To Range("d" & Rows.Count).End(xlUp).Row
   If Cells(y, 4) > 20 Then
   x = x + 1
   Else: Exit For
      End If
   Next y
   st = st & x & ","
   End If
Next x
st = Left(st, Len(st) - 1)
Range(st).Select
End Sub

Sub 选取符合条件的单元格2()
Dim x As Long
Dim rg As Range
For x = 2 To Range("d" & Rows.Count).End(xlUp).Row
If Cells(x, 4) > 20 Then
If rg Is Nothing Then
   Set rg = Rows(x)
   Else
   Set rg = Union(rg, Rows(x))
End If
End If
Next x
rg.Select
End Sub

Sub 选取符合条件的单元格3()
Dim x As Long
Dim rg As Range
For x = 2 To Range("d" & Rows.Count).End(xlUp).Row
If Cells(x, 4) > 20 Then
If rg Is Nothing Then
Set rg = Cells(x, 1).Resize(1, Columns.Count)
Else
Set rg = Union(rg, Cells(x, 1).Resize(1, Columns.Count))
rg.Select
End If
End If
Next x
End Sub

yl_li 发表于 2012-3-16 14:14

只会2种
Sub range方法()
Dim i As Byte
Dim str As String
For i = 2 To 11
   If Cells(i, 4) > 20 Then
         str = str & i & ":" & i & ","
   End If
Next i
str = Left(str, Len(str) - 1)
Range(str).Select
End Sub

Sub union方法()
Dim i As Byte
Dim rg As Range
For i = 2 To 11
   If Cells(i, 4) > 20 Then
         If rg Is Nothing Then
            Set rg = Rows(i)
         Else
            Set rg = Union(rg, Rows(i))
         End If
   End If
Next i
rg.Select
End Sub

sliang28 发表于 2012-3-16 14:51

Sub RgSelect1() 'range选择法

Dim i As Integer
Dim rg As Range
Dim rowstr As String

i = .End(xlUp).Row

rowstr = ""

For Each rg In Range("D2:D" & i)
If rg > 20 Then
   If rowstr = "" Then
         rowstr = rowstr & rg.Row & ":" & rg.Row
   Else
         rowstr = rowstr & "," & rg.Row & ":" & rg.Row
   End If
End If
Next

Range(rowstr).Select

End Sub

Sub RgSelect2() 'union选择法

Dim i As Integer
Dim j As Integer
Dim rg As Range
Dim rgs As Range

i = .End(xlUp).Row

j = 0

For Each rg In Range("D2:D" & i)
If rg > 20 Then
   If j = 0 Then
         Set rgs = rg
         j = j + 1
   Else
         Set rgs = Union(rgs, rg)
   End If
End If
Next

rgs.EntireRow.Select

End Sub

Sub RgSelect3() 'rows选择法

Dim i As Integer
Dim j As Integer
Dim rg As Range
Dim rgs As Range

i = .End(xlUp).Row

j = 0

For Each rg In Range("D2:D" & i)
If rg > 20 Then
   If j = 0 Then
         Set rgs = Rows(rg.Row & ":" & rg.Row)
         j = j + 1
   Else
         Set rgs = Union(rgs, Rows(rg.Row & ":" & rg.Row))
   End If
End If
Next

rgs.Select

End Sub

梅一枝 发表于 2012-3-16 15:39

Sub 成range()
Dim x As Integer
Dim y
For x = 2 To 11
   If Range("d" & x).Value > 20 Then
         If y = "" Then
            y = Range("d" & x).Address
         Else
            y = y & "," & Range("d" & x).Address
         End If
   End If
Next x
Range(y).EntireRow.Select
End Sub

Sub 成union()
Dim x As Integer
Dim y As Range
Dim k As Range
For x = 2 To 11
   If Range("d" & x).Value > 20 Then
         Set y = Range("d" & x)
         If k Is Nothing Then
            Set k = y
         Else
            Set k = Union(k, y)
         End If
   End If
Next x
k.EntireRow.Select
End Sub

Sub 成rows()
Dim x As Integer
Dim y As Range
For x = 2 To 11
   If Range("d" & x).Value > 20 Then
         If y Is Nothing Then
            Set y = Rows(x)
         Else
            Set y = Union(y, Rows(x))
         End If
   End If
Next x
y.Select
End Sub

个人总结：学的不扎实。

zjyxp 发表于 2012-3-16 15:46

range方法Sub t101()
Range("3:3, 5:5, 10:11").Select
End Subrows方法Sub t102()
Union(Rows("3:3"), Rows("5:5"), Rows("10:11")).Select
End Subunion方法Sub t103()
Union(Range("3:3"), Range("5:5"), Range("10:11")).Select
End Sub请老师批改指点，非常感谢！

vbamaster 发表于 2012-3-17 13:46

兰版：作业里要求用Range,row和union三种选取方法，这3个方法我都用上了，但体现在两个程序里，第3种程序的实现方法想不出来了，不知道可不可以算通过。
Sub RangSelect()
Dim sAddress As String
Dim rg As Range
For Each rg In Range("d2:d11")
   If rg.Value > 20 Then
         If sAddress = "" Then
            sAddress = rg.Address
         Else
            sAddress = sAddress & "," & rg.Address
         End If
   End If
Next rg
sAddress = "" & sAddress & ""
Range(sAddress).EntireRow.Select
End Sub
Sub UnionSelect()
Dim sAddress As String
Dim rg, rg1 As Range
For Each rg In Range("d2:d11")
   If rg.Value > 20 Then
         If rg1 Is Nothing Then
            Set rg1 = Rows(rg.Row)
         Else
            Set rg1 = Union(rg1, Rows(rg.Row))
         End If
   End If
Next rg
rg1.Select
End Sub

D05:vbamaster

兰江自由鱼 发表于 2012-3-17 15:41

我也做好了作业，不知是否正确？请批改。谢谢！

Sub 方法1() ' range()
Dim i As Integer, j As Integer
Dim ss As String
j = Range("D65536").End(xlUp).Row
For i = 2 To j
   If Range("D" & i).Value > 20 Then
         ss = ss & i & ":" & i & ","
   End If
Next i
ss = VBA.Left(ss, Len(ss) - 1)
Range(ss).Select
End Sub

Sub 方法2() 'rows()
Dim i As Integer, j As Integer, k As Integer
Dim sRg As Range
j = Range("D65536").End(xlUp).Row
For i = 2 To j
   If Range("D" & i).Value > 20 Then
         If k = 1 Then
            Set sRg = Union(sRg, Rows(i))
         Else
            Set sRg = Rows(i)
            k = 1
         End If
   End If
Next i
sRg.Select
End Sub

Sub 方法3() 'union()+ entirerow
Dim i As Integer, j As Integer, k As Integer
Dim sRg As Range, sRg2 As Range
j = Range("D65536").End(xlUp).Row
For i = 2 To j
   Set sRg2 = Range("D" & i)
   If sRg2.Value > 20 Then
         If k = 1 Then
            Set sRg = Union(sRg, sRg2)
         Else
            Set sRg = sRg2
            k = 1
         End If
   End If
Next i
sRg.Select
sRg.EntireRow.Select
End Sub

一缕忧兰 发表于 2012-3-17 17:37

A07:一缕忧兰
Sub 方法1()
Dim i As Integer
Dim m
For i = 2 To 11
If Range("D" & i).Value > 20 Then
If m = "" Then
m = Range("D" & i).Address
Else
m = m & "," & Range("D" & i).Address
End If
End If
Next i
Range(m).EntireRow.Select
End Sub

Sub 方法2()
Dim i
Dim R As Range
For i = 2 To 11
If Cells(i, "D") > 20 Then
If R Is Nothing Then
Set R = Range("D" & i)
Else
Set R = Application.Union(R, Range("D" & i))
End If
End If
Next i
R.EntireRow.Select
End Sub

Sub 方法3()
Dim i
Dim R As Range
For i = 2 To 11
If Cells(i, "D") > 20 Then
If R Is Nothing Then
Set R = Rows(i)
Else
Set R = Application.Union(R, Rows(i))
End If
End If
Next i
R.Select
End Sub

页: 1 [2] 3 4 5 6

Excel精英培训网's Archiver