Nhờ sửa code lưu dòng chọn xóa trên Listbox vào sheet khác

xuanchientn · 26/3/21

e có file excell khi em chọn xóa hết trên listbox thì dữ liệu của em vào hết sheet1, em nhờ các a,c sửa code hộ em khi em chọn xóa hết thì ở cột sheet có sheet1 , sheet2 , sheet3 , sheet4, sheet5 thì dữ liệu ở dòng sheet1,sheet2 sẽ vào sheet1 và sheet3 , sheet4, sheet5 sẽ vào sheet2 trên file excell .thanks các bác.

giaiphap · 26/3/21

xuanchientn đã viết:
e có file excell khi em chọn xóa hết trên listbox thì dữ liệu của em vào hết sheet1, em nhờ các pro sửa code hộ em khi em chọn xóa hết thì ở cột sheet có sheet1 và sheet2 thì dữ liệu ở dòng sheet nào sẽ tự vào sheet đấy trên file excell .thanks các bác.

Cho góp ý thôi nhé, còn hay không thì tùy bạn. Các thành viên trong đây hay dị ứng với từ pro nên bạn muốn nhanh được giúp đỡ thì bỏ đi từ pro đi, vì phần lớn sẽ không có ai dám nhận mình là pro đâu. Mặc dù tôi rất thích được người khác gọi mình vậy, nhưng khả năng của mình thì chưa được pro nên không dám giúp luôn (mặc dù dư sức để giúp bạn).

giaiphap · 26/3/21

xuanchientn đã viết:
e có file excell khi em chọn xóa hết trên listbox thì dữ liệu của em vào hết sheet1, em nhờ các a,c sửa code hộ em khi em chọn xóa hết thì ở cột sheet có sheet1 , sheet2 , sheet3 , sheet4, sheet5 thì dữ liệu ở dòng sheet1,sheet2 sẽ vào sheet1 và sheet3 , sheet4, sheet5 sẽ vào sheet2 trên file excell .thanks các bác.

Xem thử đúng yêu cầu chưa. Lưu ý là tiêu đề ghi rõ chút, lười gì thấy mắc sợ (Anh chị thì ghi anh chị ghi tắt là không tôn trọng người khác).

xuanchientn · 27/3/21

giaiphap đã viết:
Xem thử đúng yêu cầu chưa. Lưu ý là tiêu đề ghi rõ chút, lười gì thấy mắc sợ (Anh chị thì ghi anh chị ghi tắt là không tôn trọng người khác).

Cảm ơn anh đã giúp đỡ.lần sau em rút kinh nghiệm. anh cho em hỏi code này em có thể thêm nhiều điều kiện hơn được không anh. ví dụ có sheet1 , sheet2 , sheet3 , sheet4, sheet5 thì dữ liệu ở dòng sheet1,sheet2 sẽ vào sheet1 và sheet3 , sheet4, sheet5 sẽ vào sheet2 trên file excell được không anh.

giaiphap · 3/4/21

xuanchientn đã viết:
Cảm ơn anh đã giúp đỡ.lần sau em rút kinh nghiệm. anh cho em hỏi code này em có thể thêm nhiều điều kiện hơn được không anh. ví dụ có sheet1 , sheet2 , sheet3 , sheet4, sheet5 thì dữ liệu ở dòng sheet1,sheet2 sẽ vào sheet1 và sheet3 , sheet4, sheet5 sẽ vào sheet2 trên file excell được không anh.

Thay đoạn code btnXuatKho_Click thành.

Mã:

Private Sub btnXuatKho_Click()
    ThisWorkbook.Activate
    Dim i&, k&
    Dim ArrUndo(), ArrData(1 To 1, 1 To 6)
    Dim aRow%, jRow

If Me.XUANCHIEN1.ListIndex = -1 Then Exit Sub
aRow = Me.XUANCHIEN1.ListCount
ReDim ArrUndo(1 To aRow, 1 To 6)
Application.ScreenUpdating = False
jUndo = 0: jRow = 0
For i = 0 To Me.XUANCHIEN1.ListCount - 1
        If Me.XUANCHIEN1.Selected(i) And WorksheetExists(Me.XUANCHIEN1.List(i, 3)) Then
            With ThisWorkbook.Sheets(Me.XUANCHIEN1.List(i, 3))
                ArrData(1, 1) = .Range("A65000").End(xlUp).Row
                For k = 1 To 5
                    ArrData(1, k + 1) = Me.XUANCHIEN1.List(i, k)
                Next k
                .Range("A" & (.Range("A65000").End(xlUp).Row + 1)).Resize(, 5) = ArrData
            End With
        Else
            jUndo = jUndo + 1: ArrUndo(jUndo, 1) = jUndo
            For k = 1 To 5
                ArrUndo(jUndo, k + 1) = Me.XUANCHIEN1.List(i, k)
            Next k
        End If
    Next i
    Sheet2.Range("A2:F" & (Sheet2.Range("A65000").End(xlUp).Row + 1)).Delete
    If jUndo Then Sheet2.Range("A" & (Sheet2.Range("A65000").End(xlUp).Row + 1)).Resize(jUndo, 5) = ArrUndo
    XUANCHIEN1.Clear
    If jUndo Then
        ReDim ArrTemp(1 To jUndo, 1 To 6)
        For i = 1 To jUndo
            For k = 1 To 6
                ArrTemp(i, k) = ArrUndo(i, k)
            Next k
        Next i
        XUANCHIEN1.List() = ArrTemp
    End If
    Application.ScreenUpdating = True
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

xuanchientn · 14/4/21

giaiphap đã viết:

Thay đoạn code btnXuatKho_Click thành.

Mã:

Private Sub btnXuatKho_Click()
    ThisWorkbook.Activate
    Dim i&, k&
    Dim ArrUndo(), ArrData(1 To 1, 1 To 6)
    Dim aRow%, jRow

If Me.XUANCHIEN1.ListIndex = -1 Then Exit Sub
aRow = Me.XUANCHIEN1.ListCount
ReDim ArrUndo(1 To aRow, 1 To 6)
Application.ScreenUpdating = False
jUndo = 0: jRow = 0
For i = 0 To Me.XUANCHIEN1.ListCount - 1
        If Me.XUANCHIEN1.Selected(i) And WorksheetExists(Me.XUANCHIEN1.List(i, 3)) Then
            With ThisWorkbook.Sheets(Me.XUANCHIEN1.List(i, 3))
                ArrData(1, 1) = .Range("A65000").End(xlUp).Row
                For k = 1 To 5
                    ArrData(1, k + 1) = Me.XUANCHIEN1.List(i, k)
                Next k
                .Range("A" & (.Range("A65000").End(xlUp).Row + 1)).Resize(, 5) = ArrData
            End With
        Else
            jUndo = jUndo + 1: ArrUndo(jUndo, 1) = jUndo
            For k = 1 To 5
                ArrUndo(jUndo, k + 1) = Me.XUANCHIEN1.List(i, k)
            Next k
        End If
    Next i
    Sheet2.Range("A2:F" & (Sheet2.Range("A65000").End(xlUp).Row + 1)).Delete
    If jUndo Then Sheet2.Range("A" & (Sheet2.Range("A65000").End(xlUp).Row + 1)).Resize(jUndo, 5) = ArrUndo
    XUANCHIEN1.Clear
    If jUndo Then
        ReDim ArrTemp(1 To jUndo, 1 To 6)
        For i = 1 To jUndo
            For k = 1 To 6
                ArrTemp(i, k) = ArrUndo(i, k)
            Next k
        Next i
        XUANCHIEN1.List() = ArrTemp
    End If
    Application.ScreenUpdating = True
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function
[/cod
[/QUOTE]

giaiphap đã viết:

Thay đoạn code btnXuatKho_Click thành.

Mã:

Private Sub btnXuatKho_Click()
    ThisWorkbook.Activate
    Dim i&, k&
    Dim ArrUndo(), ArrData(1 To 1, 1 To 6)
    Dim aRow%, jRow

If Me.XUANCHIEN1.ListIndex = -1 Then Exit Sub
aRow = Me.XUANCHIEN1.ListCount
ReDim ArrUndo(1 To aRow, 1 To 6)
Application.ScreenUpdating = False
jUndo = 0: jRow = 0
For i = 0 To Me.XUANCHIEN1.ListCount - 1
        If Me.XUANCHIEN1.Selected(i) And WorksheetExists(Me.XUANCHIEN1.List(i, 3)) Then
            With ThisWorkbook.Sheets(Me.XUANCHIEN1.List(i, 3))
                ArrData(1, 1) = .Range("A65000").End(xlUp).Row
                For k = 1 To 5
                    ArrData(1, k + 1) = Me.XUANCHIEN1.List(i, k)
                Next k
                .Range("A" & (.Range("A65000").End(xlUp).Row + 1)).Resize(, 5) = ArrData
            End With
        Else
            jUndo = jUndo + 1: ArrUndo(jUndo, 1) = jUndo
            For k = 1 To 5
                ArrUndo(jUndo, k + 1) = Me.XUANCHIEN1.List(i, k)
            Next k
        End If
    Next i
    Sheet2.Range("A2:F" & (Sheet2.Range("A65000").End(xlUp).Row + 1)).Delete
    If jUndo Then Sheet2.Range("A" & (Sheet2.Range("A65000").End(xlUp).Row + 1)).Resize(jUndo, 5) = ArrUndo
    XUANCHIEN1.Clear
    If jUndo Then
        ReDim ArrTemp(1 To jUndo, 1 To 6)
        For i = 1 To jUndo
            For k = 1 To 6
                ArrTemp(i, k) = ArrUndo(i, k)
            Next k
        Next i
        XUANCHIEN1.List() = ArrTemp
    End If
    Application.ScreenUpdating = True
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

Cảm ơn anh nhiều nhé

Nhờ sửa code lưu dòng chọn xóa trên Listbox vào sheet khác

xuanchientn

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

giaiphap

==(^o^)==

File đính kèm

xuanchientn

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

xuanchientn

Thành viên mới

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng