Snasui Excel Forum

Code: Select all

Sub PasteData()
Dim rAll As Range, rs As Range
Dim r As Range, rt As Range
Sheets("ตอบแทน").Range("D6:M18").ClearContents
With Sheets("ส.ค.54")
Set rAll = .Range("A5", .Range("A" & Rows.Count).End(xlUp))
End With
Set rs = Sheets("Sheet1").Range("A1")
For Each r In rAll
    If r <> "" Then
        Set rt = Sheets("ตอบแทน").Range("D18").End(xlUp).Offset(1, 0)
        rs = r.Offset(0, 1)
        With Sheets("Sheet1")
            .Range("C3").Resize(.Range("C1"), .Range("B1")).Copy
        End With
        rt.PasteSpecial Paste:=xlPasteValues, Transpose:=True
        rs.Copy
        rt.Offset(0, -3).PasteSpecial xlPasteValues
    End If
Next r
Application.CutCopyMode = False
MsgBox "Complete."
End Sub

Code: Select all

Sub PasteWithDifSize()
Dim c%, i%, j%, k%
Dim rrAll As Range, rcAll As Range, rp As Range
Dim r As Range, r1 As Range
Sheets("Rev").Range("A6:A18,D6:M18").ClearContents
With Sheets("Aug")
    Set rcAll = .Range("B6", .Range("B6").End(xlDown))
End With
For Each r In rcAll
    With Sheets("Rev")
        If .Range("D6") = "" Then
            Set rp = .Range("D6").Resize(2, 10)
        Else
            Set rp = .Range("D18").End(xlUp).Offset(1, 0).Resize(2, 10)
        End If
    End With
    i = 0: j = 0: c = 0
    If r.Offset(0, -1) <> "" Then
        rp.Cells(1, 1).Offset(0, -3) = r
        Set rrAll = r.Offset(0, 1).Resize(1, 31)
        For Each r1 In rrAll
            i = i + 1
            If r1 <> "" Then
                c = c + 1
                j = Int((c-1) / 10) + 1
                k = (c - 1) Mod 10 + 1
                rp.Cells(j, k) = i
            End If
        Next r1
    End If
Next r
End Sub

Code: Select all

Sub PasteWithDifSize()
Dim c%, i%, j%, k%
Dim rrAll As Range, rcAll As Range, rp As Range
Dim r As Range, r1 As Range
Dim strNameSheet As String
 strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
Sheets("Rev").Range("A6:A18,D6:O18").ClearContents
'With Sheets("Aug")
With Sheets(strNameSheet)
    Set rcAll = .Range("B6", .Range("B6").End(xlDown))
End With
For Each r In rcAll
    With Sheets("Rev")
        If .Range("D6") = "" Then
            Set rp = .Range("D6").Resize(2, 10)
        Else
            Set rp = .Range("D18").End(xlUp).Offset(1, 0).Resize(2, 10)
        End If
    End With
    i = 0: j = 0: c = 0
    If r.Offset(0, -1) <> "" Then
        rp.Cells(1, 1).Offset(0, -3) = r
        Set rrAll = r.Offset(0, 1).Resize(1, 31)
        For Each r1 In rrAll
            i = i + 1
            If r1 <> "" Then
                c = c + 1
                j = Int((c - 1) / 10) + 1
                k = (c - 1) Mod 10 + 1
                rp.Cells(j, k) = i
            End If
        Next r1
        rp.Cells(1, 1).Offset(0, 10) = c
        rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
    End If
Next r
End Sub

Code: Select all

Sub PasteWithDifSize()
Dim c%, i%, j%, k%
Dim rrAll As Range, rcAll As Range, rp As Range
Dim r As Range, r1 As Range
Dim s As Integer
Dim sCount As Integer
Dim strNameSheet As String

strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
For s = 1 To Worksheets.Count
        If UCase(Worksheets(s).Name) = UCase(strNameSheet) Then
           sCount = sCount + 1
        End If
    Next
If sCount > 0 Then
      'Worksheets(strNameSheet).Select
   Else
        MsgBox "Please try again"
    End If
Sheets("Rev").Range("A6:A18,D6:Q18").ClearContents
'With Sheets("Aug")
'On Error Resume Next
With Sheets(strNameSheet)
Set rcAll = .Range("B6", .Range("B6").End(xlDown))
End With
For Each r In rcAll
    With Sheets("Rev")
    Range("L2") = strNameSheet
        If .Range("D6") = "" Then
            Set rp = .Range("D6").Resize(2, 10)
        Else
            Set rp = .Range("D18").End(xlUp).Offset(1, 0).Resize(2, 10)
       End If
    End With
    i = 0: j = 0: c = 0
    If r.Offset(0, -1) <> "" Then
        rp.Cells(1, 1).Offset(0, -3) = r
        Set rrAll = r.Offset(0, 1).Resize(1, 31)
        For Each r1 In rrAll
            i = i + 1
            If r1 <> "" Then
                c = c + 1
                j = Int((c - 1) / 10) + 1
                k = (c - 1) Mod 10 + 1
                rp.Cells(j, k) = i
            End If
        Next r1
        rp.Cells(1, 1).Offset(0, 10) = c
        rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
        rp.Cells(1, 1).Offset(0, 13) = "=RC[-3]*RC[-14]"
    End If
Next r
End Sub

Code: Select all

Sub PasteWithDifSize()
Dim c%, i%, j%, k%, s%, sCount%, strNameSheet$
Dim rrAll As Range, rcAll As Range, rp As Range
Dim r As Range, r1 As Range

strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
For s = 1 To Worksheets.Count
        If UCase(Worksheets(s).Name) = UCase(strNameSheet) Then
           sCount = sCount + 1
        End If
    Next
If sCount = 0 Then
      MsgBox "Sheet name is incorrect. Please try again."
      Exit Sub
End If
Sheets("Rev").Range("A6:A18,D6:Q18").ClearContents
With Sheets(strNameSheet)
    Set rcAll = .Range("B6", .Range("B6").End(xlDown))
End With
For Each r In rcAll
    With Sheets("Rev")
        If .Range("D6") = "" Then
            Set rp = .Range("D6").Resize(2, 10)
        Else
            Set rp = .Range("D18").End(xlUp).Offset(1, 0).Resize(2, 10)
       End If
    End With
    i = 0: j = 0: c = 0
    If r.Offset(0, -1) <> "" Then
        rp.Cells(1, 1).Offset(0, -3) = r
        Set rrAll = r.Offset(0, 1).Resize(1, 31)
        For Each r1 In rrAll
            i = i + 1
            If r1 <> "" Then
                c = c + 1
                j = Int((c - 1) / 10) + 1
                k = (c - 1) Mod 10 + 1
                rp.Cells(j, k) = i
            End If
        Next r1
        rp.Cells(1, 1).Offset(0, 10) = c
        rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
        rp.Cells(1, 1).Offset(0, 13) = "=RC[-3]*RC[-14]"
    End If
Next r
With Sheets("Rev").Range("L2")
    .Value = 1 & strNameSheet & Year(Date)
    .NumberFormat = "mmmm"
End With
End Sub

Code: Select all

Sub PasteWithDifSize()
Dim c%, i%, j%, k%, s%, sCount%, strNameSheet$
Dim rrAll As Range, rcAll As Range, rp As Range
Dim r As Range, r1 As Range

strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
For s = 1 To Worksheets.Count
        If UCase(Worksheets(s).Name) = UCase(strNameSheet) Then
           sCount = sCount + 1
        End If
    Next
If sCount = 0 Then
      MsgBox "Sheet name is incorrect. Please try again."
      Exit Sub
End If
Sheets("Rev").Range("A6:A18,D6:Q18").ClearContents
With Sheets(strNameSheet)
    Set rcAll = .Range("B6", .Range("B6").End(xlDown))
End With
For Each r In rcAll
    With Sheets("Rev")
        If .Range("D6") = "" Then
            Set rp = .Range("D6").Resize(2, 10)
        Else
            Set rp = .Range("D18").End(xlUp).Offset(1, 0).Resize(2, 10)
       End If
    End With
    i = 0: j = 0: c = 0
    If r.Offset(0, -1) <> "" Then
        rp.Cells(1, 1).Offset(0, -3) = r
        Set rrAll = r.Offset(0, 1).Resize(1, 31)
        For Each r1 In rrAll
            i = i + 1
            If r1 <> "" Then
                c = c + 1
                j = Int((c - 1) / 10) + 1
                k = (c - 1) Mod 10 + 1
                rp.Cells(j, k) = i
            End If
        Next r1
        rp.Cells(1, 1).Offset(0, 10) = c
        rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
        rp.Cells(1, 1).Offset(0, 13) = "=RC[-3]*RC[-14]"
    End If
Next r
With ActiveSheet
If .Range("D14,D15,D16,D17,D18,D19") = "" Then
    .Range("D14,D15,D16,D17,D18,D19").EntireRow.Hidden = True
    Else
    .Range("D14,D15,D16,D17,D18,D19").EntireRow.Hidden = False
  End If
  End With
With Sheets("Rev").Range("L2")
    .Value = 1 & strNameSheet & Year(Date)
    .NumberFormat = "mmmm"
End With
End Sub

Code: Select all

Option Explicit

Sub PasteWithDifSize()
Dim c%, i%, j%, k%, s%, sCount%, strNameSheet$
Dim rrAll As Range, rcAll As Range, rp As Range
Dim r As Range, r1 As Range

Sheets("Rev").Range("D6:D18").EntireRow.Hidden = False
strNameSheet = InputBox("Please enter sheet name.")
    If strNameSheet = "" Then
        Exit Sub
    End If
For s = 1 To Worksheets.Count
        If UCase(Worksheets(s).Name) = UCase(strNameSheet) Then
           sCount = sCount + 1
        End If
    Next
If sCount = 0 Then
      MsgBox "Sheet name is incorrect. Please try again."
      Exit Sub
End If
Sheets("Rev").Range("A6:A18,D6:Q18").ClearContents
With Sheets(strNameSheet)
    Set rcAll = .Range("B6", .Range("B6").End(xlDown))
End With
For Each r In rcAll
    With Sheets("Rev")
        If .Range("D6") = "" Then
            Set rp = .Range("D6").Resize(2, 10)
        Else
            Set rp = .Range("D18").End(xlUp).Offset(1, 0).Resize(2, 10)
       End If
    End With
    i = 0: j = 0: c = 0
    If r.Offset(0, -1) <> "" Then
        rp.Cells(1, 1).Offset(0, -3) = r
        Set rrAll = r.Offset(0, 1).Resize(1, 31)
        For Each r1 In rrAll
            i = i + 1
            If r1 <> "" Then
                c = c + 1
                j = Int((c - 1) / 10) + 1
                k = (c - 1) Mod 10 + 1
                rp.Cells(j, k) = i
            End If
        Next r1
        rp.Cells(1, 1).Offset(0, 10) = c
        rp.Cells(1, 1).Offset(0, 11) = "=RC[-1]*RC[-12]"
        rp.Cells(1, 1).Offset(0, 13) = "=RC[-3]*RC[-14]"
    End If
Next r
With Sheets("Rev")
    With .Range("L2")
        .Value = 1 & strNameSheet & Year(Date)
        .NumberFormat = "mmmm"
    End With
    For Each r In .Range("D6:D18")
        If r = "" Then
            r.EntireRow.Hidden = True
        End If
    Next r
End With
End Sub