Dùng VBA để chuyển đổi định dạng

Liên hệ QC
soledad_90

soledad_90

Thành viên thường trực
Tham gia
12/1/10
Bài viết
253
Được thích
47
Giới tính
Nam
Em có file yêu cầu cần chuyển đổi :
Với thông tin tại sheet Data và kết quả mong muốn tại sheet yeucau
Tại sheet yeucau em mong muốn code VBA chạy theo số tự nhiên nhưng trong giới hạn bảng tính.
Với sheet Data thì dữ liệu sẽ không giới hạn số cột và số hàng dữ liệu (A1:Y1) và Y327
Em xin cảm ơn ạ!
 

File đính kèm

  • 211123_chuyendoi dong goi giao-nhan. thanhpham-.xls
    131 KB · Đọc: 18
Sắp xếp theo thời gian sắp xếp theo bầu chọn
soledad_90 đã viết:
Em có file yêu cầu cần chuyển đổi :
Với thông tin tại sheet Data và kết quả mong muốn tại sheet yeucau
Tại sheet yeucau em mong muốn code VBA chạy theo số tự nhiên nhưng trong giới hạn bảng tính.
Với sheet Data thì dữ liệu sẽ không giới hạn số cột và số hàng dữ liệu (A1:Y1) và Y327
Em xin cảm ơn ạ!
Nhấp chuột vào đây để mở rộng...
Mong nhận được sự giúp đỡ từ diễn đàn cho topic này ạ.
Em xin cảm ơn!
 
Upvote 0
Tôi ngại làm việc với file xls lắm. Bạn chuyển nó thành xlsx rồi tính tiếp.
 
Upvote 0
Chịu thua. Code này viết rất dài dòng, rất mất thì giờ mà hiện tại thì tôi chưa thấy được cái pattern của dữ liệu.
Chịu khó chờ người sáng suốt hơn tôi.
 
Upvote 0
VetMini đã viết:
Chịu thua. Code này viết rất dài dòng, rất mất thì giờ mà hiện tại thì tôi chưa thấy được cái pattern của dữ liệu.
Chịu khó chờ người sáng suốt hơn tôi.
Nhấp chuột vào đây để mở rộng...
Chuyện code dài ngắn chả là gì cả. Nhưng muốn giúp thì trước hết phải hiểu. Người ta tung dữ liệu và kết quả mong đợi mà không một lời mô tả. Thôi thì nhìn kết quả mong đợi rồi đoán mò.

Đọc từ dòng 4 tới 34 trong sheet yeucau thì tôi thấy sao mình thông minh thế. Tự tin là mình đoán mò đúng. Nhưng đọc tiếp thì tẽn tò. Tưởng rằng cứ theo "qui luật" thì phải có Y36 = 12 nhưng lại thấy Y36 = 1, lẽ ra phải có A37:L37 = 1, 2, ..., 12 thì lại có D37:F37 = 2, 4, 6.

Thôi thì mình thuộc loại chậm hiểu, không lanh lợi như con nhà người ta ...
 
Upvote 0
batman1 đã viết:
Chuyện code dài ngắn chả là gì cả. Nhưng muốn giúp thì trước hết phải hiểu. Người ta tung dữ liệu và kết quả mong đợi mà không một lời mô tả. Thôi thì nhìn kết quả mong đợi rồi đoán mò.

Đọc từ dòng 4 tới 34 trong sheet yeucau thì tôi thấy sao mình thông minh thế. Tự tin là mình đoán mò đúng. Nhưng đọc tiếp thì tẽn tò. Tưởng rằng cứ theo "qui luật" thì phải có Y36 = 12 nhưng lại thấy Y36 = 1, lẽ ra phải có A37:L37 = 1, 2, ..., 12 thì lại có D37:F37 = 2, 4, 6.

Thôi thì mình thuộc loại chậm hiểu, không lanh lợi như con nhà người ta ...
Nhấp chuột vào đây để mở rộng...
Tuỳ theo bác nhận ra được cái pattern của nó.
Nếu nhận ra được cái rất rõ thì code dễ dàng. Nếu chỉ lờ mờ thì code rất dài, vì phải bao qua được cái chỗ lờ mờ đó.
 
Upvote 0
VetMini đã viết:
Tuỳ theo bác nhận ra được cái pattern của nó.
Nếu nhận ra được cái rất rõ thì code dễ dàng. Nếu chỉ lờ mờ thì code rất dài, vì phải bao qua được cái chỗ lờ mờ đó.
Nhấp chuột vào đây để mở rộng...
Tôi chỉ chơi khi tôi hiểu, hoặc tưởng mình hiểu. Nếu chỉ lờ mờ thì không mất công làm gì.
 
Upvote 0
batman1 đã viết:
Tôi chỉ chơi khi tôi hiểu, hoặc tưởng mình hiểu. Nếu chỉ lờ mờ thì không mất công làm gì.
Nhấp chuột vào đây để mở rộng...
Bởi vậy tôi nhường lại cho những người thích code lờ mờ.
Cũng có thể người đa đang luyện kỹ năng theo kiểu "ra đáp án tạm thật nhanh, chỉnh sửa sau".
 
Upvote 0
soledad_90 đã viết:
Em có file yêu cầu cần chuyển đổi :
Với thông tin tại sheet Data và kết quả mong muốn tại sheet yeucau
Tại sheet yeucau em mong muốn code VBA chạy theo số tự nhiên nhưng trong giới hạn bảng tính.
Với sheet Data thì dữ liệu sẽ không giới hạn số cột và số hàng dữ liệu (A1:Y1) và Y327
Em xin cảm ơn ạ!
Nhấp chuột vào đây để mở rộng...
Chạy code . . .
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), res(), b12 As Boolean
  Dim sRow&, scol&, sBox&, i&, j&, k&, c&, jC&
  With Sheets("data")
    sArr = .Range("A4", .Cells(.Range("Y" & Rows.Count).End(xlUp).Row + 1, .Range("A3").End(xlToRight).Column)).Value
  End With
  sRow = UBound(sArr):    scol = UBound(sArr, 2)
  ReDim res(1 To 1000, 1 To scol) '1.000 dong ket qua
  k = -2
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      b12 = False
      k = k + 3
      For j = 1 To scol
        res(k, j) = sArr(i, j)
        res(k + 1, j) = sArr(i + 1, j)
        If j > 2 And j < scol Then
          If res(k, j) > 11 Then b12 = True
        End If
      Next j
      If b12 Then
        sBox = res(k + 1, scol)
        jC = 0
        k = k + 2
        For c = 1 To sBox
          If jC = scol Then
            jC = 1
            k = k + 1
          Else
            jC = jC + 1
          End If
          res(k, jC) = c
        Next c
        i = i + 2
      Else
        c = 1
      End If
    ElseIf sArr(i, scol) <> Empty Then
      k = k + 1
      For j = 3 To scol - 1
        res(k, j) = sArr(i, j)
      Next j
      res(k, scol) = c
      c = c + 1
    End If
  Next i
  With Sheets("yeucau")
    .Range("A4:BA1003").Clear
    .Range("A4").Resize(k, scol) = res
    .Range("A4").Resize(k, scol).Borders.LineStyle = 1
  End With
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy code . . .
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), res(), b12 As Boolean
  Dim sRow&, scol&, sBox&, i&, j&, k&, c&, jC&
  With Sheets("data")
    sArr = .Range("A4", .Cells(.Range("Y" & Rows.Count).End(xlUp).Row + 1, .Range("A3").End(xlToRight).Column)).Value
  End With
  sRow = UBound(sArr):    scol = UBound(sArr, 2)
  ReDim res(1 To 1000, 1 To scol) '1.000 dong ket qua
  k = -2
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      b12 = False
      k = k + 3
      For j = 1 To scol
        res(k, j) = sArr(i, j)
        res(k + 1, j) = sArr(i + 1, j)
        If j > 2 And j < scol Then
          If res(k, j) > 11 Then b12 = True
        End If
      Next j
      If b12 Then
        sBox = res(k + 1, scol)
        jC = 0
        k = k + 2
        For c = 1 To sBox
          If jC = scol Then
            jC = 1
            k = k + 1
          Else
            jC = jC + 1
          End If
          res(k, jC) = c
        Next c
        i = i + 2
      Else
        c = 1
      End If
    ElseIf sArr(i, scol) <> Empty Then
      k = k + 1
      For j = 3 To scol - 1
        res(k, j) = sArr(i, j)
      Next j
      res(k, scol) = c
      c = c + 1
    End If
  Next i
  With Sheets("yeucau")
    .Range("A4:BA1003").Clear
    .Range("A4").Resize(k, scol) = res
    .Range("A4").Resize(k, scol).Borders.LineStyle = 1
  End With
End Sub
Nhấp chuột vào đây để mở rộng...

Em cảm ơn anh nhiều ạ.
Code chạy cho ra kết quả đúng rồi ạ.
 
Upvote 0
batman1 đã viết:
Đọc từ dòng 4 tới 34 trong sheet yeucau thì tôi thấy sao mình thông minh thế. Tự tin là mình đoán mò đúng. Nhưng đọc tiếp thì tẽn tò. Tưởng rằng cứ theo "qui luật" thì phải có Y36 = 12 nhưng lại thấy Y36 = 1, lẽ ra phải có A37:L37 = 1, 2, ..., 12 thì lại có D37:F37 = 2, 4, 6.
Nhấp chuột vào đây để mở rộng...
1639442505705.png

Em xin giải thích thêm về quy luật ạ ( đây là thông tin đóng gói ) sẽ khá rườm rà khi trình bày, gây khó hiểu nên em không thể hiện.
Em cảm ơn góp ý của a .
 
Upvote 0
HieuCD đã viết:
Chạy code . . .
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), res(), b12 As Boolean
  Dim sRow&, scol&, sBox&, i&, j&, k&, c&, jC&
  With Sheets("data")
    sArr = .Range("A4", .Cells(.Range("Y" & Rows.Count).End(xlUp).Row + 1, .Range("A3").End(xlToRight).Column)).Value
  End With
  sRow = UBound(sArr):    scol = UBound(sArr, 2)
  ReDim res(1 To 1000, 1 To scol) '1.000 dong ket qua
  k = -2
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      b12 = False
      k = k + 3
      For j = 1 To scol
        res(k, j) = sArr(i, j)
        res(k + 1, j) = sArr(i + 1, j)
        If j > 2 And j < scol Then
          If res(k, j) > 11 Then b12 = True
        End If
      Next j
      If b12 Then
        sBox = res(k + 1, scol)
        jC = 0
        k = k + 2
        For c = 1 To sBox
          If jC = scol Then
            jC = 1
            k = k + 1
          Else
            jC = jC + 1
          End If
          res(k, jC) = c
        Next c
        i = i + 2
      Else
        c = 1
      End If
    ElseIf sArr(i, scol) <> Empty Then
      k = k + 1
      For j = 3 To scol - 1
        res(k, j) = sArr(i, j)
      Next j
      res(k, scol) = c
      c = c + 1
    End If
  Next i
  With Sheets("yeucau")
    .Range("A4:BA1003").Clear
    .Range("A4").Resize(k, scol) = res
    .Range("A4").Resize(k, scol).Borders.LineStyle = 1
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
1639456033459.png

Sau khi e cho chạy 1 đơn hàng mới thì code hiển thị sai kết quả ạ.
Ở đây chỉ có quy luật của thông tin về đóng gói là cố định , còn số size / số lượng đôi / số thùng chắn / số thùng ghép sẽ thay đổi ạ.
soledad_90 đã viết:
View attachment 270297

Em xin giải thích thêm về quy luật ạ ( đây là thông tin đóng gói ) sẽ khá rườm rà khi trình bày, gây khó hiểu nên em không thể hiện.
Em cảm ơn góp ý của a .
Nhấp chuột vào đây để mở rộng...
Em rất mong sớm nhận được đóng góp chỉnh sửa từ anh ạ.
Em cảm ơn ạ.
 

File đính kèm

  • 211123_chuyendoi dong goi giao-nhan. thanhpham- CAPNHAT-.xlsb
    41.1 KB · Đọc: 5
Upvote 0
soledad_90 đã viết:
Em rất mong sớm nhận được đóng góp chỉnh sửa từ anh ạ.
Em cảm ơn ạ.
Nhấp chuột vào đây để mở rộng...
Khả năng là thế này. bạn thử sửa code thế này coi
Mã: 
Sub XYZ()
  Dim sArr(), res(), b12 As Boolean
  Dim sRow&, scol&, sBox&, i&, j&, k&, c&, jC&, iR&, iC&
  With Sheets("data")
    iC = .Cells(3, Columns.Count).End(1).Column
    iR = .Cells(Rows.Count, iC).End(3).Row
    sArr = .Range("A4").Resize(iR - 3, iC).Value
  End With
  sRow = UBound(sArr):    scol = UBound(sArr, 2)
  ReDim res(1 To 1000, 1 To scol) '1.000 dong ket qua
  k = -2
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      b12 = False
      k = k + 3
      For j = 1 To scol
        res(k, j) = sArr(i, j)
        res(k + 1, j) = sArr(i + 1, j)
        If j > 2 And j < scol Then
          If res(k, j) > 11 Then b12 = True
        End If
      Next j
      If b12 Then
        sBox = res(k + 1, scol)
        jC = 0
        k = k + 2
        For c = 1 To sBox
          If jC = scol Then
            jC = 1
            k = k + 1
          Else
            jC = jC + 1
          End If
          res(k, jC) = c
        Next c
        i = i + 2
      Else
        c = 1
      End If
    ElseIf sArr(i, scol) <> Empty Then
      k = k + 1
      For j = 3 To scol - 1
        res(k, j) = sArr(i, j)
      Next j
      res(k, scol) = c
      c = c + 1
    End If
  Next i
  With Sheets("yeucau")
    .Range("A4:BA1003").Clear
    .Range("A4").Resize(k, scol) = res
    .Range("A4").Resize(k, scol).Borders.LineStyle = 1
  End With
End Sub
 
Upvote 0
BuiQuangThuan đã viết:
Khả năng là thế này. bạn thử sửa code thế này coi
Mã: 
Sub XYZ()
  Dim sArr(), res(), b12 As Boolean
  Dim sRow&, scol&, sBox&, i&, j&, k&, c&, jC&, iR&, iC&
  With Sheets("data")
    iC = .Cells(3, Columns.Count).End(1).Column
    iR = .Cells(Rows.Count, iC).End(3).Row
    sArr = .Range("A4").Resize(iR - 3, iC).Value
  End With
  sRow = UBound(sArr):    scol = UBound(sArr, 2)
  ReDim res(1 To 1000, 1 To scol) '1.000 dong ket qua
  k = -2
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then
      b12 = False
      k = k + 3
      For j = 1 To scol
        res(k, j) = sArr(i, j)
        res(k + 1, j) = sArr(i + 1, j)
        If j > 2 And j < scol Then
          If res(k, j) > 11 Then b12 = True
        End If
      Next j
      If b12 Then
        sBox = res(k + 1, scol)
        jC = 0
        k = k + 2
        For c = 1 To sBox
          If jC = scol Then
            jC = 1
            k = k + 1
          Else
            jC = jC + 1
          End If
          res(k, jC) = c
        Next c
        i = i + 2
      Else
        c = 1
      End If
    ElseIf sArr(i, scol) <> Empty Then
      k = k + 1
      For j = 3 To scol - 1
        res(k, j) = sArr(i, j)
      Next j
      res(k, scol) = c
      c = c + 1
    End If
  Next i
  With Sheets("yeucau")
    .Range("A4:BA1003").Clear
    .Range("A4").Resize(k, scol) = res
    .Range("A4").Resize(k, scol).Borders.LineStyle = 1
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều nhé . Code hiện kết quả đúng rồi.
 
Upvote 0
HieuCD đã viết:
Chạy code . . .
...
Nhấp chuột vào đây để mở rộng...
Đã nói cái này dài lắm mờ. :p
Khong phải bạn viết thiếu. Mà do chính thớt cũng chưa nắm vững hết những điều kiện của mình. Phải có đồ thử rồi từ từ mới ra.
1-2 lần chưa hết các điều kiện còn ẩn bên trong đâu.
 
Upvote 0
VetMini đã viết:
Đã nói cái này dài lắm mờ. :p
Khong phải bạn viết thiếu. Mà do chính thớt cũng chưa nắm vững hết những điều kiện của mình. Phải có đồ thử rồi từ từ mới ra.
1-2 lần chưa hết các điều kiện còn ẩn bên trong đâu.
Nhấp chuột vào đây để mở rộng...
Dạ anh .
Cảm ơn anh đã nhắc nhở, đúng là lỗi từ em khi trình bày chưa hết ý .
Và em cũng xin cảm ơn anh @HieuCD và bạn @BuiQuangThuan đã giúp đỡ ạ.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

C
Code Lọc Dữ Liệu
Trả lời
2
Đọc
47
Cúc Hr
C
Y
Cách ẩn công thức 1 ô trong sheet
Trả lời
8
Đọc
68
hoangminhtien
hoangminhtien
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
4
Đọc
90
Tuấn Bụng Bự
Tuấn Bụng Bự
vuha
  • Question
Lỗi chọn dòng thứ 6 trong sheet được chọn: rows("6:6").select
Trả lời
12
Đọc
124
ptm0412
ptm0412
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
12
Đọc
19K
cantl
C
N
Giúp sửa mã code
Trả lời
4
Đọc
90
ptm0412
ptm0412
Nguyencaocuong86
Tô màu dữ liệu trùng lặp trong excel.
Trả lời
10
Đọc
112
Nguyencaocuong86
Nguyencaocuong86
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
0
Đọc
26
zarra
zarra
Hoangquyenbong
  • Question
Nhờ viết code lọc dữ liệu tại các sheet khác nhau.
Trả lời
12
Đọc
132
Hoangquyenbong
Hoangquyenbong
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
10 11 12
Trả lời
236
Đọc
12K
Ryder
Ryder
D
Giúp em công thức lấy mã vật tư gồm 14 số?
Trả lời
3
Đọc
78
hoangminhtien
hoangminhtien
HeSanbi
  • Đã giải quyết
HÀM FITROW - Co giãn dòng tự động tối ưu nhất cho Excel v2.43 (*14/10/2024)
    • Thích
    • Yêu thích
2 3
Trả lời
48
Đọc
21K
HeSanbi
HeSanbi
dunghtgiga
Tính bốn tuần cho một tháng
Trả lời
8
Đọc
215
cantl
C
L
Dùng vlookup đưa kết quả không được
Trả lời
19
Đọc
292
họ nguyễn tên thùy
họ nguyễn tên thùy
Ha Manh-LD
Thêm dòng cho 2 bảng cùng lúc
Trả lời
0
Đọc
42
Ha Manh-LD
Ha Manh-LD
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
1
Đọc
119
Hoàng Tuấn 868
H
T
Ký tự đặc biệt đại diện cho các ký tự khác trong vba là gì
Trả lời
7
Đọc
252
VetMini
V
N
Tạo, sử dụng Automation Add-in trong Excel bằng Visual C#
    • Thích
    • Yêu thích
Trả lời
19
Đọc
1K
dovandung
D
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
6
Đọc
240
Decepticon
D
keandanh141
Hướng dẫn hàm số tạo số ngẫu nhiên sao cho tổng bằng đúng 1 số
Trả lời
9
Đọc
223
CHAOQUAY
C
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom