Snasui Excel Forum

Code: Select all

Sub SaveData()
    Dim rs As Range, rsAll As Range
    Dim rt As Range, i As Integer
    Set rsAll = Sheets("Sheet1").Range("D2:D10")
    Set rt = Sheets("Sheet2").Range("A" & Rows.Count) _
        .End(xlUp).Offset(1, 0)
    rt = Sheets("Sheet1").Range("A1")
    For Each rs In rsAll
        i = i + 1
        rt.Offset(0, i) = IIf(rs, 1, 0) 'Or rt.offset(0,i) = abs(rs)
    Next rs
End Sub

Code: Select all

Dim lng As Long

Sub SaveData()
    Dim rs As Range, rsAll As Range
    Dim rt As Range, i As Integer
    Dim j As Integer
    Set rsAll = Sheets("Sheet1").Range("D2:D10")
    Set rt = Sheets("Sheet2").Range("A" & Rows.Count) _
        .End(xlUp).Offset(1, 0)
    If Application.CountIf(Sheets("Sheet2").Range("A:A"), Sheets("Sheet1").Range("A1")) > 0 Then
        j = MsgBox("คุณกำลังบันทึกข้อมูลซ้ำ คุณต้องการแก้ไขข้อมูลใช่หรือไม่?", vbYesNo)
        If j = vbYes Then
            Call EditData
            Exit Sub
        Else
            Exit Sub
        End If
    End If
    rt = Sheets("Sheet1").Range("A1")
    For Each rs In rsAll
        i = i + 1
        rt.Offset(0, i) = IIf(rs, 1, 0)
    Next rs
    MsgBox "บันทึกข้อมูลเรียบร้อยแล้ว"
End Sub

Sub ClearCheckbox()
    Range("A1,D:D,H1").ClearContents
End Sub

Sub FindData()
    Dim lCount As Long
    Dim rsSearch As Range, r As Range
    Dim rt As Range, rs As Range
    With Sheets("Sheet1")
        Set rsSearch = .Range("H1")
        Set rs = .Range("D2:D10")
    End With
    lCount = Application.CountIf( _
        Sheets("Sheet2").Range("A:A"), rsSearch)
    If lCount > 0 Then
        With Sheets("Sheet2")
        lng = Application.Match(rsSearch, _
            Sheets("Sheet2").Range("A:A"), 0)
        End With
    Else
        MsgBox "Can't find your data."
        Exit Sub
    End If
    Set rt = Sheets("Sheet2").Range("B" & lng).Resize(1, 9)
    rt.Copy
    Sheets("Sheet1").Range("D2").PasteSpecial xlPasteValues, _
        Transpose:=True
    Sheets("Sheet1").Range("A1") = rt.End(xlToLeft)
    For Each r In rs
        r = IIf(r = 1, True, False)
    Next r
    Application.CutCopyMode = False
End Sub
Sub EditData()
    Dim rs As Range, rsAll As Range
    Dim rt As Range, i As Integer
    Set rsAll = Sheets("Sheet1").Range("D2:D10")
    Set rt = Sheets("Sheet2").Range("A" & lng)
    rt = Sheets("Sheet1").Range("A1")
    For Each rs In rsAll
        i = i + 1
        rt.Offset(0, i) = IIf(rs, 1, 0)
    Next rs
    Range("A1,H1").ClearContents
    MsgBox "แก้ไขข้อมูลเรียบร้อยแล้ว"
End Sub