Dán lên không tác động đến dòng đã bị ẩn (1 người xem)

[lamchanphieu]

Mong bạn nào biết giúp mình với!!

 

[HungQuoc49]

Mong bạn nào biết giúp mình với!!

Đúng theo đầu bài thì thử code này xem sao.
Nếu đầu bài thay đổi thì chịu.

Public Sub Dan_So()
Dim r As Long, i As Long

With Sheet1
For r = 3 To 17
If .Range("A" & r).Rows.Hidden = False Then
i = i + 1
.Range("A" & r).Value = i
End If
Next r
End With

End Sub

 

[lamchanphieu]

Đúng theo đầu bài thì thử code này xem sao.
Nếu đầu bài thay đổi thì chịu.

Public Sub Dan_So()
Dim r As Long, i As Long

With Sheet1
For r = 3 To 17
If .Range("A" & r).Rows.Hidden = False Then
i = i + 1
.Range("A" & r).Value = i
End If
Next r
End With

End Sub

tôi thử chưa được, dù sao củng cảm ơn bạn nhiều!

 

[HungQuoc49]

tôi thử chưa được, dù sao củng cảm ơn bạn nhiều!

Nhấn vào cái nút "DÁN" xem kết quả cột A ra sao nhé
( Vẫn code của bài trước )

 

[Let'GâuGâu]

Mong bạn nào biết giúp mình với!!

góp thêm một đoạn code
theo mô tả của bạn thì vùng copy đến có dòng ẩn cách dòng,nên tôi viết code cho nó nhảy một dòng
các dòng ẩn không chứa số liệu nha, nó sẻ bị xóa nếu có
à quên, chọn vùng cần copy rồi chạy code

Sub dan_cach_dong()
Dim copy_rng(), i, j As Long, rng As Variant, kq(), ToRng As Range
On Error Resume Next
rng = Selection.Value
ReDim kq(1 To UBound(rng) * 2, 1 To 1)
If Err Then MsgBox "vung copy phai hang doc va nhieu hon mot dong ": Exit Sub
j = 1
If UBound(rng) > 1 Then
For i = 1 To UBound(rng)
    kq(j, 1) = rng(i, 1)
    j = j + 2
Next
End If

Set ToRng = Application.InputBox(prompt:="Chon Cell Dan", Type:=8)
ToRng.Cells(1, 1).Resize(j - 1).Value = kq

End Sub

================
cái này chắc tổng quát hơn.........(chưa thử hết các trường hợp)........heheheh

Sub dan_cach_dong()
on error resume next
Dim CoppyArr, ToArr As Variant, i, j As Long, kq(), Coppy_Rng, ToRng, cll As Range, d As Object

Set Coppy_Rng = Application.InputBox(prompt:="Chon Vung Coppy", Type:=8)
If Coppy_Rng.Rows.Count = 1 Then MsgBox "vung copy phai hang doc va nhieu hon mot dong ": Exit Sub
CoppyArr = Coppy_Rng.Value
ReDim kq(1 To UBound(CoppyArr) * 2, 1 To 1)

Set ToRng = Application.InputBox(prompt:="Chon Cell Dan", Type:=8)
If ToRng Is Nothing Then Exit Sub
ToArr = ToRng.Cells(1, 1).Resize(2 * UBound(CoppyArr)).Value

Set d = CreateObject("Scripting.Dictionary")
For Each cll In ToRng.Cells(1, 1).Resize(UBound(ToArr)).SpecialCells(12)
    d.Add (cll.Row - ToRng.Cells(1, 1).Row + 1), ""
Next

For i = 1 To UBound(ToArr)
If d.exists(i) Then
    j = j + 1
    kq(i, 1) = CoppyArr(j, 1)
Else
    kq(i, 1) = ToArr(i, 1)
End If
Next
ToRng.Cells(1, 1).Resize(i - 1).Value = kq
Set d = Nothing
Set Coppy_Rng = Nothing
Set ToRng = Nothing
End Sub

 

[lamchanphieu]

góp thêm một đoạn code
theo mô tả của bạn thì vùng copy đến có dòng ẩn cách dòng,nên tôi viết code cho nó nhảy một dòng
các dòng ẩn không chứa số liệu nha, nó sẻ bị xóa nếu có
à quên, chọn vùng cần copy rồi chạy code

sub dan_cach_dong()
dim copy_rng(), i, j as long, rng as variant, kq(), torng as range
on error resume next
rng = selection.value
redim kq(1 to ubound(rng) * 2, 1 to 1)
if err then msgbox "vung copy phai hang doc va nhieu hon mot dong ": Exit sub
j = 1
if ubound(rng) > 1 then
for i = 1 to ubound(rng)
    kq(j, 1) = rng(i, 1)
    j = j + 2
next
end if

set torng = application.inputbox(prompt:="chon cell dan", type:=8)
torng.cells(1, 1).resize(j - 1).value = kq

end sub

================
cái này chắc tổng quát hơn.........(chưa thử hết các trường hợp)........heheheh

sub dan_cach_dong()
on error resume next
dim coppyarr, toarr as variant, i, j as long, kq(), coppy_rng, torng, cll as range, d as object

set coppy_rng = application.inputbox(prompt:="chon vung coppy", type:=8)
if coppy_rng.rows.count = 1 then msgbox "vung copy phai hang doc va nhieu hon mot dong ": Exit sub
coppyarr = coppy_rng.value
redim kq(1 to ubound(coppyarr) * 2, 1 to 1)

set torng = application.inputbox(prompt:="chon cell dan", type:=8)
if torng is nothing then exit sub
toarr = torng.cells(1, 1).resize(2 * ubound(coppyarr)).value

set d = createobject("scripting.dictionary")
for each cll in torng.cells(1, 1).resize(ubound(toarr)).specialcells(12)
    d.add (cll.row - torng.cells(1, 1).row + 1), ""
next

for i = 1 to ubound(toarr)
if d.exists(i) then
    j = j + 1
    kq(i, 1) = coppyarr(j, 1)
else
    kq(i, 1) = toarr(i, 1)
end if
next
torng.cells(1, 1).resize(i - 1).value = kq
set d = nothing
set coppy_rng = nothing
set torng = nothing
end sub

đoạn code này thì đúng ý, nhưng tiếc là tôi copy từ 1 sheet khác qua thì không dán được

 

[lamchanphieu]

đoạn code này thì đúng ý, nhưng tiếc là tôi copy từ 1 sheet khác qua thì không dán được

đoạn code sau thì copy được rồi, cảm ơn bạn nhiều nhé!!