Tác dữ liệu 1 dòng thành nhiều dòng (1 người xem)

[saobekhonglac]

Chào anh/chị.

Nhờ anh/chị tách giúp em dữ liệu trong ô A1 thành 1107 dòng giúp em (từ A2 đến A1108), mỗi 1 dòng là 1 câu hỏi và đáp án.

Cám ơn.

 

[HungQuoc49]

Chào anh/chị.

Nhờ anh/chị tách giúp em dữ liệu trong ô A1 thành 1107 dòng giúp em (từ A2 đến A1108), mỗi 1 dòng là 1 câu hỏi và đáp án.

Cám ơn.

Thử đoạn code

Public Sub Tach()
Dim Chuoi, kq(), c As Long

Chuoi = Sheet1.Range("A1")
Chuoi = Replace(Chuoi, Left(Chuoi, 3), "#" & Left(Chuoi, 3))
Chuoi = Split(Chuoi, "#")
ReDim kq(1 To UBound(Chuoi), 1 To 1)

For c = 1 To UBound(Chuoi)
kq(c, 1) = Chuoi(c)
Next c

Sheet1.Range("A3:A5000").ClearContents
Sheet1.Range("A3").Resize(c - 1, 1) = kq
End Sub

 

[saobekhonglac]

Nếu dùng hàm thì có cách nào không anh

Thử đoạn code

Public Sub Tach()
Dim Chuoi, kq(), c As Long

Chuoi = Sheet1.Range("A1")
Chuoi = Replace(Chuoi, Left(Chuoi, 3), "#" & Left(Chuoi, 3))
Chuoi = Split(Chuoi, "#")
ReDim kq(1 To UBound(Chuoi), 1 To 1)

For c = 1 To UBound(Chuoi)
kq(c, 1) = Chuoi(c)
Next c

Sheet1.Range("A3:A5000").ClearContents
Sheet1.Range("A3").Resize(c - 1, 1) = kq
End Sub

 

[giangleloi]

Chào anh/chị.

Nhờ anh/chị tách giúp em dữ liệu trong ô A1 thành 1107 dòng giúp em (từ A2 đến A1108), mỗi 1 dòng là 1 câu hỏi và đáp án.

Cám ơn.

Góp vui với bạn đoạn code này:

Sub saobekhonglac()
  Dim text, Str, clb
  text = [A1].Value
  Str = Left(text, 6)
  text = Replace(text, Str, vbLf & Str)
  Set clb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  clb.SetText text
  clb.PutInClipboard
  [A2].PasteSpecial
  Set clb = Nothing
End Sub

 

[HungQuoc49]

Nếu dùng hàm thì có cách nào không anh

Hàm chắc có nhưng có lẽ phải kèm cột phụ cho dễ nhìn

 

[saobekhonglac]

Nếu ô A1 có số ký tự câu hỏi không giống nhau thì có làm được không anh. Ví dụ nếu mỗi câu hỏi đều bắt đầu bằng chữ "Câu:......... đáp an:.......;" (kết thúc bằng dấu ";")

Ví dụ: (Câu 2: ABCDE XYZ; Câu 3: KTKFJDK YHDA; Câu 4: GKKSJWKKDSJF GKKSLA

Góp vui với bạn đoạn code này:

Sub saobekhonglac()
  Dim text, Str, clb
  text = [A1].Value
  Str = Left(text, 6)
  text = Replace(text, Str, vbLf & Str)
  Set clb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  clb.SetText text
  clb.PutInClipboard
  [A2].PasteSpecial
  Set clb = Nothing
End Sub

 

[saobekhonglac]

Anh làm giúp em nha. Em không rành về VBA

Hàm chắc có nhưng có lẽ phải kèm cột phụ cho dễ nhìn

 

[giangleloi]

Nếu ô A1 có số ký tự câu hỏi không giống nhau thì có làm được không anh. Ví dụ nếu mỗi câu hỏi đều bắt đầu bằng chữ "Câu:......... đáp an:.......;" (kết thúc bằng dấu ";")

Bạn cứ thử tự test xem. Nếu không được thì lại quăng file lên đây, mà hình như bạn muốn xài công thức, chịu khó chờ thành viên khác giúp xem sao.

 

[doveandrose]

Góp vui với bạn đoạn code này:

Sub saobekhonglac()
  Dim text, Str, clb
  text = [A1].Value
  Str = Left(text, 6)
  text = Replace(text, Str, vbLf & Str)
  Set clb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  clb.SetText text
  clb.PutInClipboard
  [A2].PasteSpecial
  Set clb = Nothing
End Sub

ủa cái gì đây trời ? vật thể lạ mới đáp xuống diễn đàn này chăng ?

 

[giangleloi]

Ví dụ: (Câu 2: ABCDE XYZ; Câu 3: KTKFJDK YHDA; Câu 4: GKKSJWKKDSJF GKKSLA

Sửa lại như thế này xem:

Sub saobekhonglac()
  Dim text, clb
  text = [A1].Value
  text = Replace(text, ";", vbLf)
  Set clb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  clb.SetText text
  clb.PutInClipboard
  [A2].PasteSpecial
  Set clb = Nothing
End Sub

 

[doatmenhhon]

Uhm. Tôi cũng thắc mắc nãy giờ...hic hic...kinh quá!!!

Có lẽ Giang cao thủ xuống dòng (alt + f11) khi gặp đáp án rồi ốp thư viện vào ^^

 

[giangleloi]

ủa cái gì đây trời ? vật thể lạ mới đáp xuống diễn đàn này chăng ?

Vụ này diễn đàn có lâu rồi mà. Học lỏm của đại ca "NDU" ấy chứ.

 

[thangbithu]

Nếu dùng hàm thì có cách nào không anh

Dùng hàm thì được nhưng do đoạn text bạn quá dài nên nó báo lỗi Value (vượt quá số ký tự cho phép trong 1 cell 32767, mình đã thử, chỉ làm được đến câu thứ 30 thôi, chứ 40 là báo value rồi, nên bài này nên dùng code thì tốt hơn bạn ơi.

Công thức: ví dụ copy 30 câu đầu vào ô A2

A3 = TRIM(MID(SUBSTITUTE(" "&$A$2;" Đáp";REPT(" ";1000)&"Đáp");ROWS($A$3:A3)*1000;1000))

 

[giaiphap]

Dùng hàm thì được nhưng do đoạn text bạn quá dài nên nó báo lỗi Value (vượt quá số ký tự cho phép trong 1 cell 32767, mình đã thử, chỉ làm được đến câu thứ 30 thôi, chứ 40 là báo value rồi, nên bài này nên dùng code thì tốt hơn bạn ơi.

Công thức: ví dụ copy 30 câu đầu vào ô A2

A3 = TRIM(MID(SUBSTITUTE(" "&$A$2;" Đáp";REPT(" ";1000)&"Đáp");ROWS($A$3:A3)*1000;1000))

Quả đúng như vậy, mình cũng cài công thức. Nhưng công thức của mình là dạng mãng nên chỉ dừng lại ở số thứ 20 thôi, trở về sau báo lỗi #Value

 

[HungQuoc49]

Anh làm giúp em nha. Em không rành về VBA

Dùng cột phụ
Lỗi câu cuối cùng, đang kiểm tra lại, bạn xem thử, nếu ok sẽ tính tiếp.
---
Sửa công thức tại C3 sẽ xử lý được cả câu cuối.
C3=TRIM(IF(ROWS($C$3:C3)=1,MID($A$1,1,FIND("Đáp án",$A$1,2)-1),MID($A$1,D2+1,IFERROR(FIND("Đáp án",$A$1,D2+2)-D2-1,LEN($A$1)))))
Copy xuống dưới
---
code trong file có sửa lại tham số hàm left()

 

[giaiphap]

Sửa lại như thế này xem:

Sub saobekhonglac()
  Dim text, clb
  text = [A1].Value
  text = Replace(text, ";", vbLf)
  Set clb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  clb.SetText text
  clb.PutInClipboard
  [A2].PasteSpecial
  Set clb = Nothing
End Sub

Mình mới thấy cách này lần đâu tiên đây, hay nhỉ! sao lại nghĩ tuyệt quá!

 

[bebo021999]

Thích thì chiều, công thức tại A2:

=LEFT(A1,SEARCH("Đáp án hình",A1,2)-1)

A3:

=MID($A$1,SEARCH("Đáp án hình",$A$1,SEARCH(A2,$A$1)+1),SEARCH("Đáp án hình",$A$1,
SEARCH("Đáp án hình",$A$1,SEARCH(A2,$A$1)+1)+1)-SEARCH("Đáp án hình",$A$1,SEARCH(A2,$A$1)+1))

Kéo xuống.