ขอคำแนะนำเรื่องการนับชีทที่มีจำนวนไม่แน่นอน VBA

[sweetken]

ต้องการนำข้อมูลจากไฟล์งานที่ จำนวนชีทไม่แน่นอนมาใช้ เราจะมีวิธีการนับชีทอย่างไรค่ะ ที่จะทำให้ vba จะทราบว่า เราต้องการนับชีทก่อนว่ามีจำนวนชีทเท่าไหร่ แล้วค่อยรันข้อมูลมาอีกชีทหนึ่ง เพื่อเป็นกรารวมข้อมูลสรุป (การนำข้อมูลแต่ละชีทมาสรุปนิดทำได้แล้ว ติดตรงจำนวนชีทที่เพิ่มไม่แน่นอนค่ะ)

ขอบพระคุณค่ะ

[DhitiBank]

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

http://www.mrexcel.com/forum/excel-ques ... kbook.html

[sweetken]

ขอบคุณค่ะ ไม่รู้ต้องใช้ for next หรือเปล่า มีไฟล์ตัวอย่างมาให้ดู คือ หน้า Glass นิดทำข้อมูลได้หมดแล้ว ติดตรงแผ่นชีทจำนวนไม่แน่นอนเลยไปต่อไม่ได้ จะพยายามค่ะ

[niwat2811]

Code: Select all

Sub test()
Dim ws As Worksheet
For Each ws In Worksheets
    If ws.Name <> "Glass" Then
        'other code
    End If
Next ws
End Sub

ลองแบบนี้ดูว่าใช้ได้ตามต้องการไหมครับ

[sweetken]

ขอบคุณมากนะคะ จะรีบนำไปประยุกต์ใช้ต่อค่ะ ยังไม่ตรงตามต้องการเท่าไหร่ แต่พอเห็นแนวทางแล้วค่ะ

[sweetken]

Code: Select all

Sub Glass()
Application.ScreenUpdating = False
Dim last As Integer
Dim i As Integer
Dim ir As Long

Sheets(1).Select
    Range("B5").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Glass"
    'Sheets("Glass").Select
    [a1] = "Panel"
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(1).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O7:U" & last).Select
    'Range("J7:M" & a).Select
    Selection.Copy
    'Sheets.Add After:=Sheets(Sheets.Count)
     Sheets("Glass").Select
    Range("B1").Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
    If Range("b" & i) <> "" Then
    [a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    
     
    End If
  Next i
  

    'sheet2
    Sheets(2).Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Glass").Select
   
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(2).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O8:U" & last).Select
    'Range("J7:M" & a).Select
    Selection.Copy
    'Sheets.Add After:=Sheets(Sheets.Count)
     Sheets("Glass").Select
    Range("B" & last).Select
   [b100].End(xlUp).Offset(1, 0).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
   If Range("b" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    End If
  Next i
  
    
'sheet3
    Sheets(3).Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Glass").Select
   
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(3).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O8:U" & last).Select
    'Range("J7:M" & a).Select
    Selection.Copy
    'Sheets.Add After:=Sheets(Sheets.Count)
     Sheets("Glass").Select
    Range("B" & last).Select
   [b100].End(xlUp).Offset(1, 0).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
   If Range("b" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    End If
  Next i
  [i5].Select
  
  'sheet4
    Sheets(4).Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Glass").Select
   
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(4).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O8:U" & last).Select
    'Range("J7:M" & a).Select
    Selection.Copy
    'Sheets.Add After:=Sheets(Sheets.Count)
     Sheets("Glass").Select
    Range("B" & last).Select
   [b100].End(xlUp).Offset(1, 0).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
   If Range("b" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    End If
  Next i
  
  
  
  'sheet5
    Sheets(5).Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Glass").Select
   
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(5).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O8:U" & last).Select
    'Range("J7:M" & a).Select
    Selection.Copy
    'Sheets.Add After:=Sheets(Sheets.Count)
     Sheets("Glass").Select
    Range("B" & last).Select
   [b100].End(xlUp).Offset(1, 0).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
   If Range("b" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    End If
  Next i
  
  
    'sheet6
    Sheets(6).Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Glass").Select
   
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(6).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O8:U" & last).Select
   
    Selection.Copy
  
     Sheets("Glass").Select
    Range("B" & last).Select
   [b100].End(xlUp).Offset(1, 0).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
   If Range("b" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    End If
  Next i
  
    'Sheet7
    Sheets(7).Select
    Range("B5").Select
    Selection.Copy
    
    Sheets("Glass").Select
   
       [a300].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    
Sheets(7).Select
Range("o16").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
    Range("O8:U" & last).Select
   
    Selection.Copy
  
     Sheets("Glass").Select
    Range("B" & last).Select
   [b100].End(xlUp).Offset(1, 0).Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
ir = Range("a" & Rows.Count).End(xlUp).Row
For i = 1 To ir Step 1
If Range("a" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
   If Range("b" & i) <> "" Then
[a300].End(xlUp).Copy
    [a300].End(xlUp).Offset(1, 0).Select
     ActiveSheet.Paste
     End If
    Next i
    ir = Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To ir Step 1
     If Range("b" & i) = "" Then
    '[a300].End(xlUp).Copy
    [a300].End(xlUp).Delete
    End If
  Next i
  Columns("A:H").EntireColumn.AutoFit
  
  Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft
    
    Range("a300").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
         Range("A2:g" & last).Select
    'Sheets("Glass").[a1].CurrentRegion.Select
    'Rows("1" & last).Select
    Selection.RowHeight = 18.75
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:F1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    
     Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Name"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "=RC[-3]&""""&RC[-2]&""""&RC[-1]"
    Range("D3").Select
    
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D1000")
    Range("D2:D1000").Select
    Columns("D:D").EntireColumn.AutoFit
    
     Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("a300").Select
Selection.End(xlUp).Select
last = ActiveCell.Row
         Range("A2:g" & last).Select
    'Sheets("Glass").[a2].CurrentRegion.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Range("A2:G2").Select
    Selection.Font.Bold = True
    End Sub
  

พอรันแล้วจะได้หน้า Glass ค่ะ ตอนแรกไม่ทราบว่าจะมีชีทเพิ่ม เลยทำแบบใช้ลำดับชีทเลย ตอนนี้มีชีทเพิ่มเรื่อยๆ เลยต้องหาแนวทางการเขียนใหม่ค่ะ

[DhitiBank]

ปกติแล้ว ชีท "Glass" ไม่มีอยู่ในไฟล์นี้ใช่ไหมครับ (เห็นในคำสั่งมีการเพิ่มเข้าไปเอง)

[sweetken]

ไม่มีค่ะ ชีท Glass ต้องเพิ่มเข้าไปใหม่ แล้วยังต้องมีชีท อลูมิเนียมด้วย ตอนนี้ติดปัญหาที่ว่า พอรันแล้ว มันเอาชีท อลูมิเนียม มารวมด้วย
เลยอยากจะถามว่า เรากันชีทที่ไม่ต้องการจะนำข้อมูลมารวมออกได้ไหมค่ะ

[DhitiBank]

ไม่มีค่ะ ชีท Glass ต้องเพิ่มเข้าไปใหม่ แล้วยังต้องมีชีท อลูมิเนียมด้วย ตอนนี้ติดปัญหาที่ว่า พอรันแล้ว มันเอาชีท อลูมิเนียม มารวมด้วย
เลยอยากจะถามว่า เรากันชีทที่ไม่ต้องการจะนำข้อมูลมารวมออกได้ไหมค่ะ

ได้ครับ ต้องดูว่าชีทที่เก็บข้อมูลกระจกต่างจากชีทที่เก็บข้อมูลอะลูมิเนียมยังไง เช่น อาจเป็นรูปแบบของ "ชื่อชีท" หรืออื่นๆ หากทราบแบบนี้ก็จะสามารถเขียนคำสั่งได้ว่า หากเจอเงื่อนไขแบบนี้ แสดงว่าเป็นชีทประเภทนี้นะ อะไรแบบนี้ครับ

[sweetken]

เข้าใจแล้วค่ะ ขอบคุณสำหรับคำแนะนำนะคะ

[DhitiBank]

ลองเอาโค้ดนี้ไปปรับใช้ดูครับ

Code: Select all

Sub AddGlass()
    Dim ws As Worksheet, wGlass As Worksheet, _
        bChk As Boolean, wbAct As Workbook, i As Integer, _
        vAny As Variant, r As Range, rG As Range
    
    Set wbAct = ThisWorkbook
    '~~> ตรวจว่ามีชีท Glass หรือไม่
    For Each ws In wbAct.Sheets
        If ws.Name = "Glass" Then bChk = True
    Next ws
    '~~> หากไม่มีให้สร้าง
    If Not bChk Then
        wbAct.Sheets.Add after:=Worksheets(Sheets.Count)
        ActiveSheet.Name = "Glass"
    End If
    Set wGlass = wbAct.Sheets("glass")
    With wGlass
        vAny = Array("Panel", "Glass", "CODE", "Name", "W", "H", "Q'Ty")
        .Range("a1").Resize(1, UBound(vAny) + 1).Value = vAny
    End With
    '~~> เริ่มดึงข้อมูลมาแสดงที่ชีท Glass
    For Each ws In wbAct.Sheets
        If ws.Name Like "L-*" Then
            Set r = ws.Range("o8:o" & ws.Range("o30").End(xlUp).Row)
            With wGlass
                Set rG = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(r.Rows.Count, 1)
            End With
            rG = ws.Name
            rG.Offset(, 1).Value = r.Value
            rG.Offset(, 2) = r.Offset(, 3).Value
            For i = 4 To 6
                rG.Offset(, i).Value = r.Offset(, i).Value
            Next i
        End If
    Next ws
    With wGlass
        Set rG = .Range("a1").CurrentRegion
    End With
    Set rG = rG.Offset(1, 3).Resize(rG.Rows.Count - 1, 1)
    For Each r In rG
        r.Value = r.Offset(, -3).Value & r.Offset(, -2).Value & r.Offset(, -1).Value
    Next r
End Sub

สร้างโมดูลใหม่ คัดลอกโค้ดนี้ไปวาง แล้วลองรันดูนะครับ

[sweetken]

ขอบพระคุณมากค่ะ ใช้ได้ตามต้องการเลยค่ะ

[sweetken]

ขอรบกวนอีกนิดนะคะ ถ้าจะให้อธิบายโค๊ดให้หน่อยค่ะ มันยากมากเลยไม่ค่อยเข้าใจค่ะ

[snasui]

ไม่เข้าใจตรงไหนให้ยกมาถามเฉพาะตรงนั้น ค่อยๆ ถามตอบกันไปครับ