Excel Forum

Code: Select all

Sub Macro6()
    Application.ScreenUpdating = False
    Dim FormWs As Worksheet
    Dim lngLastRow As Long
    Dim lngPosition As Long
    Dim lr As Long
    Set FormWs = Sheets("sheet1")
    lngLastRow = FormWs.Range("C" & Rows.Count).End(xlUp).Row
    FormWs.Range("C5:H14" & lngLastRow).Copy
    With Worksheets("sheet1")
        lngRowNum = Application.WorksheetFunction.CountIf( _
            .Range("U3:U" & .Range("U65536").End(xlUp).Row), Sheets("Sheet1").Range("U3"))
        If lngRowNum = 0 Then
            Sheets("sheet1").Range("U65536").End(xlUp).Offset(1, 0) _
                .PasteSpecial xlPasteValues, Transpose:=True
        Else
        With Worksheets("sheet1")
            lngPosition = Application.WorksheetFunction.Match( _
                Sheets("Sheet1").Range("c5"), .Range("U3:U" & .Range("U" & Rows.Count) _
                .End(xlUp).Row), 0)
            Sheets("sheet1").Range("U" & (2 + lngPosition)) _
                .PasteSpecial xlPasteValues, Transpose:=True  'เลข2+inPosition คือ จำนวนแถวก่อนวางข้อมูล
            End With
        End If
        With Worksheets("sheet1")
            lr = .Range("U" & Rows.Count).End(xlUp).Row
            Set irRange = Sheets("sheet1").Range("U3:Z" & lr)
            irRange.Borders.LineStyle = xlContinuous
            irRange.Sort Key1:=Sheets("sheet1").Range("U3"), _
                Order1:=xlAscending, Header:=xlGuess
        End With
    End With
    Sheets("sheet1").Range("K5:P14").Select
    Selection.Copy
    Sheets("sheet1").Range("C5").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Code: Select all

Dim rAll As Range, r As Range
Dim f As Long, i As Integer
With Sheets("Sheet1")
    If .Range("c5").Value = "" Then End
    Set rAll = .Range("c5:c100").SpecialCells(xlCellTypeFormulas, 1)
    For Each r In rAll
        f = Application.CountIf(.Range("u3:u1000"), r.Value)
        If f > 0 Then
            i = Application.Match(r.Value, .Range("u3:u1000"), 0)
            .Range("u3:u1000")(i).Resize(1, 6).Value = r.Resize(1, 6).Value
        End If
    Next r
End With