Nhờ anh chị rút ngắn code tìm kiếm và cập nhật dữ liệu sang Sheet khác

quyenpv · 4/8/22

Em chào anh chị!
Em đang có nhiều Sheet mỗi Sheet có nhiều thông tin khác nhau để điền thông tin và cập nhật sang Sheet tổng "CT_BTS" em đã xoá bớt đi. Các Sheet có thông tin cập nhật sang có cấu trúc các dòng đầu giống y hệt nhau, thông tin sau sẽ khác để xuất sang file Word
Khi em đã hoàn thành nhập thông tin nó sẽ chạy code và đồng thời cập nhật thông tin sang Sheet "CT_BTS". Mong anh chị hỗ trợ rút ngắn code cần thiết thay vì em If .. ElseIf nhiều ạ
1. Sheet CT_BTS

2. Các Sheet nhập thông tin

3. Code em đang dùng

Mã:

Public Const s_SoHD As Integer = 11
Public Const s_Ngayky As Integer = 12
Public Const XHH_NgBGHT As Integer = 19

Sub Export_HSPly_BTS()

    Dim FindString  As String
    Dim Rng         As Range
    Dim sColum         'As Integer

    FindString = ActiveSheets.Range("D6").value
    sColum = 3
    With Sheets("CT_BTS")
        If .FilterMode Then
            .ShowAllData
        End If
    End With
    If ActiveWorkbook.ActiveSheet.Name = "XHH_DN" Then

        'Ben gin Update thong tin vao ho so CT_BTS

        If Trim(FindString) <> "" Then
            With Sheets("CT_BTS").Range("C:C")
                Set Rng = .Find(What:=FindString, _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
                If Not Rng Is Nothing Then
                    Application.GoTo Rng, True         'Nhay den vi tri Cell duoc tim thay
                        'So Hop dong
                        ActiveCell.Offset(0, s_SoHD - sColum).value = Sheets("XHH_DN").Range("D11").value
                        'Ngay Ky Hop dong
                        ActiveCell.Offset(0, s_Ngayky - sColum).value = Sheets("XHH_DN").Range("E12").value
                        'Ngay Ban giao Ha tang
                        ActiveCell.Offset(0, XHH_NgBGHT - sColum).value = Sheets("XHH_DN").Range("E15").value
                Else
                    msgbox "Khong tim thay"
                End If
            End With
        End If
        'End Update thong tin
    ElseIf ActiveWorkbook.ActiveSheet.Name = "XHH_CN" Then

        'Ben gin Update thong tin vao ho so CT_BTS

        If Trim(FindString) <> "" Then
            With Sheets("CT_BTS").Range("C:C")
                Set Rng = .Find(What:=FindString, _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
                If Not Rng Is Nothing Then
                    Application.GoTo Rng, True         'Nhay den vi tri Cell duoc tim thay
                        'So Hop dong
                        ActiveCell.Offset(0, s_SoHD - sColum).value = Sheets("XHH_CN").Range("D11").value
                        'Ngay Ky Hop dong
                        ActiveCell.Offset(0, s_Ngayky - sColum).value = Sheets("XHH_CN").Range("E12").value
                        'Ngay Ban giao Ha tang
                        ActiveCell.Offset(0, XHH_NgBGHT - sColum).value = Sheets("XHH_CN").Range("E15").value
                Else
                    msgbox "Khong tim thay"
                End If
            End With
        End If
        'End Update thong tiN
    Else
        msgbox "Khong tim thay du lieu"
    End If
    msgbox "Da xong"
End Sub

SA_DQ · 4/8/22

Dòng lệnh: FindString = ActiveSheets.Range("D6").value
Tiềm ẩn nguy cơ không mong muốn trong tham biến FindString
. . . . . .

quyenpv · 4/8/22

Dạ có cách nào ổn và rút ngắn được đoạn code mà nếu Activesheet nó lấy giá trị cập nhật được sang sheet CT_BTS không anh

HieuCD · 5/8/22

quyenpv đã viết:

Em chào anh chị!
Em đang có nhiều Sheet mỗi Sheet có nhiều thông tin khác nhau để điền thông tin và cập nhật sang Sheet tổng "CT_BTS" em đã xoá bớt đi. Các Sheet có thông tin cập nhật sang có cấu trúc các dòng đầu giống y hệt nhau, thông tin sau sẽ khác để xuất sang file Word
Khi em đã hoàn thành nhập thông tin nó sẽ chạy code và đồng thời cập nhật thông tin sang Sheet "CT_BTS". Mong anh chị hỗ trợ rút ngắn code cần thiết thay vì em If .. ElseIf nhiều ạ
1. Sheet CT_BTS

View attachment 279606

2. Các Sheet nhập thông tin

View attachment 279607

3. Code em đang dùng

Mã:

Public Const s_SoHD As Integer = 11
Public Const s_Ngayky As Integer = 12
Public Const XHH_NgBGHT As Integer = 19

Sub Export_HSPly_BTS()

    Dim FindString  As String
    Dim Rng         As Range
    Dim sColum         'As Integer

    FindString = ActiveSheets.Range("D6").value
    sColum = 3
    With Sheets("CT_BTS")
        If .FilterMode Then
            .ShowAllData
        End If
    End With
    If ActiveWorkbook.ActiveSheet.Name = "XHH_DN" Then

        'Ben gin Update thong tin vao ho so CT_BTS

        If Trim(FindString) <> "" Then
            With Sheets("CT_BTS").Range("C:C")
                Set Rng = .Find(What:=FindString, _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
                If Not Rng Is Nothing Then
                    Application.GoTo Rng, True         'Nhay den vi tri Cell duoc tim thay
                        'So Hop dong
                        ActiveCell.Offset(0, s_SoHD - sColum).value = Sheets("XHH_DN").Range("D11").value
                        'Ngay Ky Hop dong
                        ActiveCell.Offset(0, s_Ngayky - sColum).value = Sheets("XHH_DN").Range("E12").value
                        'Ngay Ban giao Ha tang
                        ActiveCell.Offset(0, XHH_NgBGHT - sColum).value = Sheets("XHH_DN").Range("E15").value
                Else
                    msgbox "Khong tim thay"
                End If
            End With
        End If
        'End Update thong tin
    ElseIf ActiveWorkbook.ActiveSheet.Name = "XHH_CN" Then

        'Ben gin Update thong tin vao ho so CT_BTS

        If Trim(FindString) <> "" Then
            With Sheets("CT_BTS").Range("C:C")
                Set Rng = .Find(What:=FindString, _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
                If Not Rng Is Nothing Then
                    Application.GoTo Rng, True         'Nhay den vi tri Cell duoc tim thay
                        'So Hop dong
                        ActiveCell.Offset(0, s_SoHD - sColum).value = Sheets("XHH_CN").Range("D11").value
                        'Ngay Ky Hop dong
                        ActiveCell.Offset(0, s_Ngayky - sColum).value = Sheets("XHH_CN").Range("E12").value
                        'Ngay Ban giao Ha tang
                        ActiveCell.Offset(0, XHH_NgBGHT - sColum).value = Sheets("XHH_CN").Range("E15").value
                Else
                    msgbox "Khong tim thay"
                End If
            End With
        End If
        'End Update thong tiN
    Else
        msgbox "Khong tim thay du lieu"
    End If
    msgbox "Da xong"
End Sub

Tự chỉnh cột kết quả

Mã:

Option Explicit
Sub Export_HSPly_BTS()
  Dim sh As Worksheet, shBC As Worksheet, MaTram$, sCol&, eRow&, i&
 
  Set sh = ThisWorkbook.ActiveSheet
  MaTram = sh.Range("D6").Value
  If Trim(MaTram) <> "" Then
    sCol = 3
    Set shBC = Sheets("CT_BTS")
    If shBC.FilterMode Then shBC.ShowAllData
    eRow = shBC.Range("C1000000").End(xlUp).Row
    For i = 12 To eRow
      If shBC.Range("C" & i).Value2 = MaTram Then
        shBC.Range("K" & i).Value2 = sh.Range("D11").Value
        shBC.Range("L" & i).Value2 = sh.Range("E12").Value
        shBC.Range("S" & i).Value2 = sh.Range("E15").Value
        MsgBox "Da xong"
        Exit Sub
      End If
    Next i
  End If
  MsgBox "Khong tim thay du lieu"
End Sub

quyenpv · 5/8/22

HieuCD đã viết:

Tự chỉnh cột kết quả

Mã:

Option Explicit
Sub Export_HSPly_BTS()
  Dim sh As Worksheet, shBC As Worksheet, MaTram$, sCol&, eRow&, i&
 
  Set sh = ThisWorkbook.ActiveSheet
  MaTram = sh.Range("D6").Value
  If Trim(MaTram) <> "" Then
    sCol = 3
    Set shBC = Sheets("CT_BTS")
    If shBC.FilterMode Then shBC.ShowAllData
    eRow = shBC.Range("C1000000").End(xlUp).Row
    For i = 12 To eRow
      If shBC.Range("C" & i).Value2 = MaTram Then
        shBC.Range("K" & i).Value2 = sh.Range("D11").Value
        shBC.Range("L" & i).Value2 = sh.Range("E12").Value
        shBC.Range("S" & i).Value2 = sh.Range("E15").Value
        MsgBox "Da xong"
        Exit Sub
      End If
    Next i
  End If
  MsgBox "Khong tim thay du lieu"
End Sub

Em cám ơn anh! Code cập nhật đúng mong muốn rồi ạ

Nhờ anh chị rút ngắn code tìm kiếm và cập nhật dữ liệu sang Sheet khác

quyenpv

Thu nhặt kiến thức

File đính kèm

SA_DQ

/(hông là gì!

quyenpv

Thu nhặt kiến thức

HieuCD

Chuyên gia GPE

quyenpv

Thu nhặt kiến thức

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

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