Xin code tự xóa hàng và tự coppy dữ liệu. (1 người xem)

[lysamtanhaccs4]

chào các bạn!
mình có file như sau :
tại sheet Data:

1. từ cột C đến cột I khi nhấn space bar 1 lần thì tự coppy dữ liệu ở hàng trên tương ứng xuống (VD khi nhấn khoảng trắng ở C4 thì coppy C3 xuống C4)
2. trong sheet Data có rất nhiều hàng trống nên xin code xóa hàng trống khi côt A,B,C =empty

tại sheet Finished
hàng nào hiện finished thì delete luôn hàng đó

Thanks các bạn nhiều.

 

[mhung12005]

chào các bạn!
mình có file như sau :
tại sheet Data:

1. từ cột C đến cột I khi nhấn space bar 1 lần thì tự coppy dữ liệu ở hàng trên tương ứng xuống (VD khi nhấn khoảng trắng ở C4 thì coppy C3 xuống C4)
2. trong sheet Data có rất nhiều hàng trống nên xin code xóa hàng trống khi côt A,B,C =empty

tại sheet Finished
hàng nào hiện finished thì delete luôn hàng đó

Thanks các bạn nhiều.

Chào bạn,

Yêu cầu 1 của bạn chỉ cần làm như sau:

Đặt con trỏ vào ô C4 và nhấn Ctrl + D.

Còn các yêu cầu khác bạn xem file đính kèm nhé.

 

[Quang_Hải]

chào các bạn!
mình có file như sau :
tại sheet Data:

1. từ cột C đến cột I khi nhấn space bar 1 lần thì tự coppy dữ liệu ở hàng trên tương ứng xuống (VD khi nhấn khoảng trắng ở C4 thì coppy C3 xuống C4)
2. trong sheet Data có rất nhiều hàng trống nên xin code xóa hàng trống khi côt A,B,C =empty

tại sheet Finished
hàng nào hiện finished thì delete luôn hàng đó

Thanks các bạn nhiều.

Muốn xài phím spacebar cho lệnh copy thì đơn giản có thể dùng Onkey để gán vào, nhưng rồi làm sao nhập khoảng trắng khi cần xài phím này??? Lạ quá!

 

[Quang_Hải]

Chào bạn,

Yêu cầu 1 của bạn chỉ cần làm như sau:

Đặt con trỏ vào ô C4 và nhấn Ctrl + D.

Còn các yêu cầu khác bạn xem file đính kèm nhé.

Xoá dòng mình vẫn thích xóa bằng mảng hơn. Sau khi xử lý thì đập 1 phát xuống sheet mới sướng

Sub Delete_Empty()
Dim Sarr(), Darr()
Dim I As Long, J As Long, X As Long, LastRow As Long
LastRow = Sheets("Data").Cells.SpecialCells(11).Row
Sarr = Sheets("Data").Range("A3", "M" & LastRow).Value
ReDim Darr(1 To UBound(Sarr), 1 To UBound(Sarr, 2))
For I = 1 To UBound(Sarr)
    If Sarr(I, 1) <> "" Then
        If Sarr(I, 2) <> "" Then
            If Sarr(I, 3) <> "" Then
                J = J + 1
                For X = 1 To UBound(Sarr, 2)
                    Darr(J, X) = Sarr(I, X)
                Next
            End If
        End If
    End If
Next
Sheets("Data").[A3].Resize(UBound(Sarr), UBound(Sarr, 2)) = Darr
End Sub

Sub Delete_Finished()
Dim Sarr(), Darr()
Dim I As Long, J As Long, X As Long, LastRow As Long
LastRow = Sheets("Finished").Cells.SpecialCells(11).Row
Sarr = Sheets("Finished").Range("A2", "C" & LastRow).Value
ReDim Darr(1 To UBound(Sarr), 1 To UBound(Sarr, 2))
For I = 1 To UBound(Sarr)
    If Sarr(I, 3) <> "finished" Then
        J = J + 1
        For X = 1 To UBound(Sarr, 2)
            Darr(J, X) = Sarr(I, X)
        Next
    End If
Next
Sheets("Finished").[A2].Resize(UBound(Sarr), UBound(Sarr, 2)) = Darr
End Sub

Còn muốn dùng thanh Spacebar để gán lệnh Ctrl +D thì thế này

Sub CellCopy()
      SendKeys ("^d")
End Sub

Khi chọn vào phạm vi cột C tới cột I thì SpaceBar có tác dụng như Ctrl +D, ra khỏi vùng thì trở lại bình thường
Nhưng nếu làm vậy thì nên dùng sự kiện Double_Click cho nhanh

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
    If .Column < 10 And .Column > 2 Then
        Application.OnKey "{32}", "CellCopy"
    Else
        Application.OnKey "{32}"
    End If
End With
End Sub

 

[lysamtanhaccs4]

sao e ko thể coi code của bạn mhung12005 dc nhỉ ?

 

[lysamtanhaccs4]

ban Quanghai1969 cho mình hỏi thêm xíu nhé !
tại sheet finished nếu bất kỳ hàng nào tại cột A có dữ liệu thì bên cột finished sẽ paste công thức =IFERROR(IF(VLOOKUP(VALUE(A2),Data!C:M,11,0)>0,"Finished",""),"").
(dữ liệu đưa vô cột A bằng cách paste là chủ yếu nhập tay thì it)
thanks nhiều.

 

[Quang_Hải]

ban Quanghai1969 cho mình hỏi thêm xíu nhé !
tại sheet finished nếu bất kỳ hàng nào tại cột A có dữ liệu thì bên cột finished sẽ paste công thức =IFERROR(IF(VLOOKUP(VALUE(A2),Data!C:M,11,0)>0,"Finished",""),"").
(dữ liệu đưa vô cột A bằng cách paste là chủ yếu nhập tay thì it)
thanks nhiều.

Bạn muốn có chưa 'finished' phải không?

Sub FormulaAdd()
Dim Sarr(), Darr(), I
Sarr = Sheets("Data").Range("C3", Sheets("Data").[C65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For I = 1 To UBound(Sarr)
      If Sarr(I, 1) <> "" Then
         If Not .exists(Val(Sarr(I, 1))) Then
            .Add Val(Sarr(I, 1)), ""
         End If
      End If
   Next
   With Sheets("Finished")
      .[C2:C10000].ClearContents
      Darr = .Range(.[A2], .[A65536].End(3)).Resize(, 3).Value
   End With
   For I = 1 To UBound(Darr)
      If .exists(Val(Darr(I, 1))) Then
         Darr(I, 3) = "finished"
      End If
   Next
End With
Sheets("Finished").[A2].Resize(I - 1, 3) = Darr
End Sub

 

[lysamtanhaccs4]

em có code như bên dưới nhưng khi nhập thì nó chạy nhưng khi paste hoăc kéo thì nó hổng chạy có cách náo cho nó chạy trong mọi trường hợp ko ?

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Column = 3 Then
Range("A" & Target.Row).Select
Selection.FillDown
Range("B" & Target.Row).Select
Selection.FillDown
Range("J" & Target.Row).Select
Selection.FillDown
Range("K" & Target.Row).Select
Selection.FillDown
Range("L" & Target.Row).Select
Selection.FillDown
Range("M" & Target.Row).Select
Selection.FillDown
Range("N" & Target.Row).Select
Selection.FillDown
End If

 

[lysamtanhaccs4]

Bạn muốn có chưa 'finished' phải không?

Sub FormulaAdd()
Dim Sarr(), Darr(), I
Sarr = Sheets("Data").Range("C3", Sheets("Data").[C65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For I = 1 To UBound(Sarr)
      If Sarr(I, 1) <> "" Then
         If Not .exists(Val(Sarr(I, 1))) Then
            .Add Val(Sarr(I, 1)), ""
         End If
      End If
   Next
   With Sheets("Finished")
      .[C2:C10000].ClearContents
      Darr = .Range(.[A2], .[A65536].End(3)).Resize(, 3).Value
   End With
   For I = 1 To UBound(Darr)
      If .exists(Val(Darr(I, 1))) Then
         Darr(I, 3) = "finished"
      End If
   Next
End With
Sheets("Finished").[A2].Resize(I - 1, 3) = Darr
End Sub

sao e đưa vô nó ko chạy bác ơi