PDA

View Full Version : VBA และ การMergeCell



anntiant
18 May 2007, 01:52
คือต้องการจะ Merge Cell คะ แต่ข้อมูลมีเป็นจำนวนมาก
หนูจึงคิดว่าน่าจะใช้ Macro แต่ข้อมูลที่จะ Merge ให้เป็น 1 Cell
ก็มีจำนวนไม่เท่ากัน
หนูก็เลยจะใช้ VBA แต่ลองเขียนเท่าไหร่ก็ไม่ได้สักที จึงอยากให้ช่วยดูให้หน่อยคะว่า
หนูเขียนผิดตรงไหน


Sub Test()

Dim a As String
Dim countaTxt, StartTxt, c As Integer

countaTxt = 1
StartTxt = 1
c = 0
Sheets("Sheet1").Select

Do
a = Worksheets("sheet1").Cells(countaTxt, 1).Value

If a <> "" Then
StartTxt = countaTxt
countaTxt = countaTxt + 1
End If
Do
If a = "" Then
c = c + 1
countaTxt = countaTxt + 1
End If
Loop Until a <> ""
Sheet1.Range(Cells(StartTxt, 1), Cells(StartTxt + c, 1)).Merge
Loop Until Range("D20").Value = ""
End Sub
เพื่อให้เข้าใจง่ายขึ้น หนูได้แนบไฟล์ให้ดูด้วยคะ
คือทำจาก Sheet1 ให้ออกมาแบบ Sheet2

anntiant
18 May 2007, 09:06
code แรก เขียนไม่ทำการ Merge เลย
ส่วน code ข้างล่างนี้ มันจะ Merge 1 ครั้ง คะ
ช่วยบอกหน่อยคะว่า code ผิดตรงไหน


Sub Merge_Test()
Dim a, b As String
Dim countaTxt, cRowTxt, c As Integer
countaTxt = 1 ' row ของ A
cRowTxt = 1 'rowแรกที่ใช้ merge
c = 0 ' ตัวนับ
Sheets("Sheet1").Select
Range("A1:A19").Select
Do
If a <> "" Then
a = Worksheets("sheet1").Cells(countaTxt, 1).Value
cRowTxt = countaTxt
End If
countaTxt = countaTxt + 1
Do
a = Worksheets("sheet1").Cells(countaTxt, 1).Value
If a = "" Then
c = c + 1
Else: End If
countaTxt = countaTxt + 1
b = Worksheets("sheet1").Cells(countaTxt, 1).Value
Loop Until b <> ""
ActiveCell.Range(Cells(cRowTxt, 1), Cells(cRowTxt + c, 1)).Merge
Loop Until Range("A19").Select
End Sub

ขอบคุณคะ

rundim
18 May 2007, 09:17
แนวความคิดดีใช้ได้ครับ เพราะการทำ loop ต้องใจเย็นนิดนึ่งครับ เพราะจะทำให้ ขาดส่วนเช็คที่ถูกต้องได้
ผมแก้จาก Code เดิมให้นิดเดียวเองครับ ลองดูครับว่าผิดพลาดตรงไหน


Sub Test()
Dim a As String
Dim countaTxt, StartTxt, c As Integer
countaTxt = 1
StartTxt = 1
c = 0
Sheets("Sheet1").Select
'Range("D20").Value = 0
Do
Do
a = Worksheets("sheet1").Cells(countaTxt, 1).Value
If a <> "" Then
StartTxt = countaTxt
countaTxt = countaTxt + 1
End If
Loop Until a = ""
Do
If a = "" Then
a = Worksheets("sheet1").Cells(countaTxt, 1).Value
c = c + 1
countaTxt = countaTxt + 1
MsgBox c, vbOKOnly
' Range("D20").Value = c
End If
' If Worksheets("sheet1").Cells(c, 4).Value = "" Then GoTo outloop

Loop Until a <> ""
Sheet1.Range(Cells(StartTxt, 1), Cells(c, 1)).Merge
StartTxt = c + 1
Loop Until Worksheets("sheet1").Cells(StartTxt + 1, 4).Value = ""
'outloop:
End Sub

anntiant
18 May 2007, 10:02
ขอบคุณ คุณ rundim มากนะคะที่มาช่วยดู code ให้