เก็บโค๊ดไว้ในตัวแปรได้มั้ยครับ หรือทำเป็นฟังชั่น เพราะโค๊ดยาว

[Vespaclassic]

หลักการทำงานของโปรแกรมของผมคือ

รับค่ามาจาก cell "C1" sheet "SHAPE"
กดคลิกที่ button จะทำการ copy รูปภาพ จาก SHEET "SHAPE" ไปยัง SHEET"pic1 และ SHEET "pic2" ตาม cell ที่กำหนดไว้
ค่าที่รับมาจาก cell "C1" sheet "SHAPE" จะเป็นการระบุจำนวนรูปภาพที่ copy
โค๊ดชุดนี้นทำงานได้ปกติ

แต่บางครั้งผมมีการรับค่ามา จำนวน 100 ซึ่งโค๊ดจะยาวมาก จะไม่สามารถรันได้ เกินขอบเขตของ vba

คำถามคือ ชุดโค๊ดนี้สามารถใส่ไว้ในตัวแปรได้หรือไม่ครับ หรือทำเป็นฟังชั่นได้มั้ย
โค๊ดนี้คือ copy รูปภาพ 1 รูป

Code: Select all

 
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select

ส่วนอันนี้คือโค๊ด copy รูป 3 รูป ซึ่งเวลารับค่าตัวเลขจำนวนมาก โค๊ดจะซ้ำๆกัน ทำให้เปลืองเนื้อที่

Code: Select all

Sub Button1()

Select Case Range("C3")

Case "1"
On Error Resume Next
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
Case "2"
On Error Resume Next
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
 '2
    Sheets("SHAPE").Select
    Range("B3").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
Case "3"
  On Error Resume Next
  '1
    Sheets("SHAPE").Select
    Range("B2").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B2").Select
    ActiveSheet.Pictures.Paste.Select
'2
    Sheets("SHAPE").Select
    Range("B3").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B3").Select
    ActiveSheet.Pictures.Paste.Select
'3
    Sheets("SHAPE").Select
    Range("B4").Select
    Selection.Copy
    Sheets("pic1").Select
    Range("B4").Select
    ActiveSheet.Pictures.Paste.Select
    
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = 36.5
    Selection.ShapeRange.Width = 101

    Sheets("pic2").Select
    Range("B4").Select
    ActiveSheet.Pictures.Paste.Select
    End Select
End Sub

[snasui]

กรุณาแนบไฟล์ที่มี Code มาพร้อมแล้วจะได้ดูต่อไปจากนั้น

สำหรับการเขียน Code เพื่อจัดการรูปจำนวนมากเราจะไม่เขียน Code ซ้ำแต่จะใช้การ Loop เข้ามาช่วยครับ

ดูตัวอย่างการ Loop ได้ที่นี่แล้วปรับใช้ดูครับ wordpress/?s=loop, search.php?keywords=loop&terms=all&auth ... mit=Search

[Vespaclassic]

ลองไปศึกษาดูครับ

ผมได้แนบไฟล์ใหม่ไปแล้วครับ

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Sub Button1()
    Dim l As Long, tg As Range
    Dim i As Integer, k As Integer
    i = 1
    Sheets("pic1").DrawingObjects.Delete
    For l = 1 To Sheets("SHAPE").Range("c3").Value
        Sheets("SHAPE").Range("b1").Offset(i, 0).Copy
        With Sheets("pic1")
            .Activate
            Set tg = .Range("b1").Offset(i, k)
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height '36.5
                .Width = tg.Width '101
            End With
        End With
        Application.CutCopyMode = False
        If i = 12 Then
            i = 1
            k = k + 1
        Else
            i = i + 1
        End If
    Next l
End Sub

[Vespaclassic]

ขอบคุณมากครับ ตัวอย่างโค๊ดที่ให้มา สั้นและดีมากเลยครับ

แต่ผมติดปัญหาเพิ่มครับ


โดยปกติ sheet pic1 ผมจะ วางรูป ลงมาแค่ 20 รูป (อันนี้ทำได้) แล้วข้ามลงไปอีกไปมาณ 10 cell ถึงจะวางรูปอีกที่ ตามไฟล์ตัวอย่างที่แนบมา

และ sheet pic2 วางรูปแนวคอลัม

ผมลองแก้โค้ดที่ให้ตัวอย่างมา

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Sub Button1()
    Dim l As Long, tg As Range
    Dim i As Integer, k As Integer
    Dim j As Integer, m As Integer, n As Integer
    i = 0
    j = 0
    Sheets("pic1").DrawingObjects.Delete
    Sheets("pic2").DrawingObjects.Delete
    For l = 1 To Sheets("SHAPE").Range("c3").Value
        Sheets("SHAPE").Range("b1").Offset(l, 0).Copy
    
        With Sheets("pic1")
            .Activate
            Set tg = .Range("b2").Offset(i, 0).MergeArea
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height
                .Width = tg.Width
            End With
            k = k + 1
        End With
       If k Mod 10 = 0 Then
          i = i + 8
       Else
          i = i + 2
       End If
       
       With Sheets("pic2")
            .Activate
            Set tg = .Range("b2").Offset(j, n).MergeArea
            tg.Select
            With .Pictures.Paste.ShapeRange
                .LockAspectRatio = msoFalse
                .Height = tg.Height
                .Width = tg.Width
            End With
            m = m + 1
        End With
       If m Mod 5 = 0 Then
          n = n + 4
          j = 0
       Else
          j = j + 5
       End If
       Application.CutCopyMode = False
    Next l
End Sub

[Vespaclassic]

โห สุดยอดมากเลยครับ ขอบคุณมากเลยครับ


ผมขอถามอีกนิดครับ

ตรง sheet pic2 จะเขียนโค็ดยังไงให้วางรูปไปทางขวาก่อนครับ ตามไฟล ที่แนบไปครั้งก่อนครับ จะเรียงจากซ้ายมาขวา พอครบ 3 แล้วเริ่มใหม่

[snasui]

สำหรับการการปรับ Code ที่ได้รับคำตอบไปแล้วจะต้องปรับกันมาเอง ติดปัญหาแล้วค่อยถามกันต่อ ไม่สามารถถามต่อเนื่องโดยไม่ผ่านการปรับด้วยตนเองมาก่อนได้ครับ

[Vespaclassic]

ขอบคุณมากครับ ขอไปปรับก่อนครับ แล้วจะมาแจ้งให้ทราบครับ

[Vespaclassic]

ทำได้แล้วนะครับ ขอบคุณมากเลยครับ ทำความเข้าใจกับโค๊ด แล้วปรับแค่นิดเดียวจริงๆ