Nhờ giúp tạo macro in theo list hồ sơ, có quy định sheet in theo mỗi số thứ tự (2 người xem)

[diennv50]

Mình muốn tạo macro in list hồ sơ theo thứ tự từ a đến b, kèm theo điều kiện để chọn sheet in theo yêu cầu.

 

[PacificPR]

Mình muốn tạo macro in list hồ sơ theo thứ tự từ a đến b, kèm theo điều kiện để chọn sheet in theo yêu cầu.

Bạn tham khảo thử

Sub InBB()
    Dim Rng As Range, Cll As Range, SoBB As String
With Sheet1
    Set Rng = .Range("A11", .Range("A" & Rows.Count).End(xlUp))
End With
With Sheet2
    For Each Cll In Rng
        If Cll.Value <> Empty And IsNumeric(Cll.Value) Then
            .Range("N55").Value = Cll.Value
            .PrintPreview
            SoBB = .Range("A53").Value
            If InStrRev(SoBB, "VC", -1, vbBinaryCompare) > 0 Then
                Sheet3.PrintPreview: Sheet4.PrintPreview: GoTo Tiep
            End If
            If InStrRev(SoBB, "ATGT", -1, vbBinaryCompare) > 0 Then
                Sheet5.PrintPreview: GoTo Tiep
            End If
            If InStrRev(SoBB, "BT", -1, vbBinaryCompare) > 0 Then
                Sheet4.PrintPreview
            End If
        End If
Tiep:
    Next
End With
End Sub

Khi nào ưng cái bụng thì thay PrintPreview bằng PrintOut nhoé

 

[tuan16]

Bạn tham khảo thử

Sub InBB()
    Dim Rng As Range, Cll As Range, SoBB As String
With Sheet1
    Set Rng = .Range("A11", .Range("A" & Rows.Count).End(xlUp))
End With
With Sheet2
    For Each Cll In Rng
        If Cll.Value <> Empty And IsNumeric(Cll.Value) Then
            .Range("N55").Value = Cll.Value
            .PrintPreview
            SoBB = .Range("A53").Value
            If InStrRev(SoBB, "VC", -1, vbBinaryCompare) > 0 Then
                Sheet3.PrintPreview: Sheet4.PrintPreview: GoTo Tiep
            End If
            If InStrRev(SoBB, "ATGT", -1, vbBinaryCompare) > 0 Then
                Sheet5.PrintPreview: GoTo Tiep
            End If
            If InStrRev(SoBB, "BT", -1, vbBinaryCompare) > 0 Then
                Sheet4.PrintPreview
            End If
        End If
Tiep:
    Next
End With
End Sub

Khi nào ưng cái bụng thì thay PrintPreview bằng PrintOut nhoé

em hỏi thêm chút. bây giờ mình muốn chọn số thứ tự in biên bản thì làm thế nào ạ.... ví dụ chỉ in biên bản theo số thựu tự từ 2-5 chẳng hạn ạ

 

[PacificPR]

em hỏi thêm chút. bây giờ mình muốn chọn số thứ tự in biên bản thì làm thế nào ạ.... ví dụ chỉ in biên bản theo số thựu tự từ 2-5 chẳng hạn ạ

Bạn có muốn cái Form như thế này không

​

 

[tuan16]

Bạn có muốn cái Form như thế này không

View attachment 236957​

dạ vâng... hướng dẫn em với ạ... em cũng đang muốn làm 1 forrm như này trên biên bản trên. vậy thêm code như nào ạ

 

[PacificPR]

dạ vâng... hướng dẫn em với ạ... em cũng đang muốn làm 1 forrm như này trên biên bản trên. vậy thêm code như nào ạ

Thái Lọ nhà mình sao mà chán thế. Viết cho đúng chính tả tí coi nào

 

[tuan16]

Thái Lọ nhà mình sao mà chán thế. Viết cho đúng chính tả tí coi nào

Hướng dẫn em với ạ.

 

[PacificPR]

Hướng dẫn em với ạ.

Để chiều nhé Bạn. Giờ phải đi mâm mân mất rồi

 

[tuan16]

Để chiều nhé Bạn. Giờ phải đi mâm mân mất rồi

giúp em cái form như này với ạ. Khi mình ấn vào nút Print hiện ra một Form để mình chọn in từ biên bản này đến biên bản kia. Em làm mà nó không chạy được

 

[PacificPR]

giúp em cái form như này với ạ. Khi mình ấn vào nút Print hiện ra một Form để mình chọn in từ biên bản này đến biên bản kia. Em làm mà nó không chạy được

Bạn tải File Bài 8 xem thử

 

[tuan16]

Bạn tải File Bài 8 xem thử

Đúng rồi ạ. Em cảm ơn nhiều ạ

 

[tuan16]

Bạn tải File Bài 8 xem thử

Dạ... Có hàm nào xử lý được chuỗi dữ liệu này không ạ

 

[PacificPR]

Dạ... Có hàm nào xử lý được chuỗi dữ liệu này không ạ

Hàm độ thì có Bạn à

 

[tuan16]

Hàm độ thì có Bạn à

Giúp thêm em về hàm này với ạ... Em có nhiều chuỗi phải nối kiểu này.

 

[PacificPR]

Giúp thêm em về hàm này với ạ... Em có nhiều chuỗi phải nối kiểu này.

Bạn thử cái hàm này xem sao

Function UniqueTextJoin(ByVal Table_Array As Range, Optional Delimiter As String) As String
    Dim sArr, Str, N As Long
    Dim Dic As Object, Tmp, Khoa As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Table_Array.Value
For Each Str In sArr
    Tmp = Split(Str, Delimiter)
    For N = 0 To UBound(Tmp)
        If Tmp(N) <> Empty Then
            Khoa = Trim(Tmp(N))
            If Not Dic.Exists(Khoa) Then Dic.Add Khoa, ""
        End If
    Next N
Next
If Dic.Count Then UniqueTextJoin = Join(Dic.Keys, Delimiter)
End Function

D7=UniqueTextJoin(B5:B9;", ")

 

[tuan16]

Bạn thử cái hàm này xem sao

Function UniqueTextJoin(ByVal Table_Array As Range, Optional Delimiter As String) As String
    Dim sArr, Str, N As Long
    Dim Dic As Object, Tmp, Khoa As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Table_Array.Value
For Each Str In sArr
    Tmp = Split(Str, Delimiter)
    For N = 0 To UBound(Tmp)
        If Tmp(N) <> Empty Then
            Khoa = Trim(Tmp(N))
            If Not Dic.Exists(Khoa) Then Dic.Add Khoa, ""
        End If
    Next N
Next
If Dic.Count Then UniqueTextJoin = Join(Dic.Keys, Delimiter)
End Function

D7=UniqueTextJoin(B5:B9;", ")

Bạn thử cái hàm này xem sao

Function UniqueTextJoin(ByVal Table_Array As Range, Optional Delimiter As String) As String
    Dim sArr, Str, N As Long
    Dim Dic As Object, Tmp, Khoa As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Table_Array.Value
For Each Str In sArr
    Tmp = Split(Str, Delimiter)
    For N = 0 To UBound(Tmp)
        If Tmp(N) <> Empty Then
            Khoa = Trim(Tmp(N))
            If Not Dic.Exists(Khoa) Then Dic.Add Khoa, ""
        End If
    Next N
Next
If Dic.Count Then UniqueTextJoin = Join(Dic.Keys, Delimiter)
End Function

D7=UniqueTextJoin(B5:B9;", ")

Em copy vào sao mà nó không chạy ra được kết quả mong muốn ạ

 

[PacificPR]

Em copy vào sao mà nó không chạy ra được kết quả mong muốn ạ

Uổi. Bây giờ mới đọc lại hoá ra Bạn không phải là Chủ Topic.

 

[tuan16]

Uổi. Bây giờ mới đọc lại hoá ra Bạn không phải là Chủ Topic.

Em vào diễn đàn thấy có bạn thắc mắc giống mình nên tham gia topic luôn... Em cảm ơn bác nhiều

 

[tuan16]

Uổi. Bây giờ mới đọc lại hoá ra Bạn không phải là Chủ Topic.

Em hỏi thêm bác về cách tính này với ạ

 

[PacificPR]

Em hỏi thêm bác về cách tính này với ạ

Thêm nhiều thế

Function SumDate(ByVal Date_value As Date, _
        ByVal Table_Lookup As Range, ByVal Col_Index As Long) As Long
    Dim sArr(), i As Long, fDate As Date, eDate As Date, Sum_Date As Long
sArr = Table_Lookup.Value
For i = 1 To UBound(sArr)
    If sArr(i, Col_Index) <> Empty Then
        fDate = sArr(i, 1): eDate = sArr(i, 2)
        If Date_value <= eDate Then
            If Date_value >= fDate Then
                Sum_Date = sArr(i, Col_Index) + Sum_Date
            End If
        End If
    End If
Next i
SumDate = Sum_Date
End Function