Chuyển đổi dữ liệu excel

Liên hệ QC
S

satthuvae

Thành viên thường trực
Tham gia
12/3/09
Bài viết
381
Được thích
52
E chào Anh/Chị trên diễn đàn.

Em có một File excel gốc, nhưng e không biết sử dụng hàm nào để ra File chuyển đổi.

Do dữ liệu khá nhiều, e chuyển thủ công khá mất thời gian.

Em xin gửi File up lên, Anh, chị có cách nào tháo gỡ giúp em. E đã làm thủ công trên File chuyển đổi.

Em xin cám ơn rất nhiều à.
 

File đính kèm

  • Chuyển đổi tự động.xls
    3.3 MB · Đọc: 16
satthuvae đã viết:
E chào Anh/Chị trên diễn đàn.

Em có một File excel gốc, nhưng e không biết sử dụng hàm nào để ra File chuyển đổi.

Do dữ liệu khá nhiều, e chuyển thủ công khá mất thời gian.

Em xin gửi File up lên, Anh, chị có cách nào tháo gỡ giúp em. E đã làm thủ công trên File chuyển đổi.

Em xin cám ơn rất nhiều à.
Nhấp chuột vào đây để mở rộng...
Dùng VBA không bạn.
 
Bài đã được tự động gộp:

satthuvae đã viết:
Dạ, e không biết dùng như thế nào, nhờ anh có VBA được thì tốt quá, tiết kiệm nhiều thời gian quá à.

Nhờ anh giúp.
Nhấp chuột vào đây để mở rộng...
Dùng code của anh @HieuCD thử nhé
Mã: 
Sub Tach()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String

  Application.ScreenUpdating = False
  With Sheets("Loc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("A7:F" & i).Clear
    If i > 4 Then .Range("A6:F6").ClearContents
  End With

  With Sheets("Goc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 1) <> sArr(i - 1, 1) Then fRow = i
    If sArr(i, 5) > 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    Else
      tkCo = sArr(i, 4)
    End If
 
    If sArr(i, 1) <> sArr(i + 1, 1) Then
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
   
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST > 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("Loc")
    If k Then
      .Range("A6:F6").Resize(k) = Res
      If k > 1 Then
        .Range("A6:F6").Copy
        .Range("A6:F6").Resize(k).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
      End If
    End If
  End With
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • Chuyển đổi tự động.xlsm
    1.4 MB · Đọc: 8
Lần chỉnh sửa cuối:
LamNA đã viết:
Bài đã được tự động gộp:


Dùng code của anh @HieuCD thử nhé
Mã: 
Sub Tach()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String

  Application.ScreenUpdating = False
  With Sheets("Loc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("A7:F" & i).Clear
    If i > 4 Then .Range("A6:F6").ClearContents
  End With

  With Sheets("Goc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 1) <> sArr(i - 1, 1) Then fRow = i
    If sArr(i, 5) > 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    Else
      tkCo = sArr(i, 4)
    End If

    If sArr(i, 1) <> sArr(i + 1, 1) Then
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
  
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST > 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("Loc")
    If k Then
      .Range("A6:F6").Resize(k) = Res
      If k > 1 Then
        .Range("A6:F6").Copy
        .Range("A6:F6").Resize(k).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
      End If
    End If
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn Anh.

Em đang xem chuyển đổi thì bị lệch cụ thể như sau, của anh chạy số tiền, nhưng cột E không đúng với cột E e làm thủ công.

214719
 
satthuvae đã viết:
E chào Anh/Chị trên diễn đàn.

Em có một File excel gốc, nhưng e không biết sử dụng hàm nào để ra File chuyển đổi.

Do dữ liệu khá nhiều, e chuyển thủ công khá mất thời gian.

Em xin gửi File up lên, Anh, chị có cách nào tháo gỡ giúp em. E đã làm thủ công trên File chuyển đổi.

Em xin cám ơn rất nhiều à.
Nhấp chuột vào đây để mở rộng...
Có bút toán đỏ nên chỉnh điều kiện ST lại
Mã: 
Sub Tach()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String
 
  Application.ScreenUpdating = False
  With Sheets("Loc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("A7:F" & i).Clear
    If i > 4 Then .Range("A6:F6").ClearContents
  End With
 
  With Sheets("Goc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 2) <> sArr(i - 1, 2) Then fRow = i
    If sArr(i, 5) <> 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    Else
      tkCo = sArr(i, 4)
    End If
    
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
      
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST <> 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("Loc")
    If k Then
      .Range("A6:F6").Resize(k) = Res
      If k > 1 Then
        .Range("A6:F6").Copy
        .Range("A6:F6").Resize(k).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
      End If
    End If
  End With
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • Chuyển đổi tự động.xlsm
    1.8 MB · Đọc: 8
Mình làm được 75% rồi, giờ chỉ còn làm sao xử lý được cột E là xong mà nghĩ ko ra hic hic
 

File đính kèm

  • Chuyển đổi tự động.xls
    3.4 MB · Đọc: 5
HieuCD đã viết:
Có bút toán đỏ nên chỉnh điều kiện ST lại
Mã: 
Sub Tach()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String

  Application.ScreenUpdating = False
  With Sheets("Loc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("A7:F" & i).Clear
    If i > 4 Then .Range("A6:F6").ClearContents
  End With

  With Sheets("Goc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 2) <> sArr(i - 1, 2) Then fRow = i
    If sArr(i, 5) <> 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    Else
      tkCo = sArr(i, 4)
    End If
   
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
     
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST <> 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("Loc")
    If k Then
      .Range("A6:F6").Resize(k) = Res
      If k > 1 Then
        .Range("A6:F6").Copy
        .Range("A6:F6").Resize(k).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
      End If
    End If
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn anh rất nhiều à.

Còn một điểm nữa nhờ anh xem lại giúp em.

214736

Kết quả ra cụ thể à

214737

Mong anh xem giúp em.

E cám ơn Anh.
 
HieuCD đã viết:
Code của mình chỉ xử lý 1 nợ nhiều có hoặc 1 có nhiều nợ, dữ liệu của bạn có nhiều nợ nhiều có, khi rảnh mình sẽ viết thêm trường hợp nầy
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh, mong anh xem giúp.
Bài đã được tự động gộp:

HieuCD đã viết:
Code của mình chỉ xử lý 1 nợ nhiều có hoặc 1 có nhiều nợ, dữ liệu của bạn có nhiều nợ nhiều có, khi rảnh mình sẽ viết thêm trường hợp nầy
Nhấp chuột vào đây để mở rộng...
Dữ liệu của e, e thấy code của anh, chạy lấy mặc định tài khoản cuối, nhờ anh xử lý, chỉ coi đó là 2 dòng vì giống nhau về số tiền, thì code mặc lấy luôn dòng kế tiếp. Cám ơn anh.
Bài đã được tự động gộp:

 
Lần chỉnh sửa cuối:
satthuvae đã viết:
Cảm ơn anh, mong anh xem giúp.
Bài đã được tự động gộp:


Dữ liệu của e, e thấy code của anh, chạy lấy mặc định tài khoản cuối, nhờ anh xử lý, chỉ coi đó là 2 dòng vì giống nhau về số tiền, thì code mặc lấy luôn dòng kế tiếp. Cám ơn anh.
Bài đã được tự động gộp:
Nhấp chuột vào đây để mở rộng...
Code chỉ dùng cho file của bạn
Kiểm tra lại
Mã: 
Sub Tach()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String
 
  Application.ScreenUpdating = False
  With Sheets("Loc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("A6:F" & i).ClearContents
  End With
 
  With Sheets("Goc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 2) <> sArr(i - 1, 2) Then fRow = i
    If sArr(i, 5) <> 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    ElseIf sArr(i, 6) <> 0 Then
      tkCo = sArr(i, 4)
    End If
    
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      For n = fRow To i - 1
        If sArr(n, 1) & sArr(n, 2) & sArr(n, 3) = _
            sArr(n + 1, 1) & sArr(n + 1, 2) & sArr(n + 1, 3) Then
          If sArr(n, 4) <> sArr(n + 1, 4) Then
            If sArr(n, 5) <> 0 And sArr(n, 5) = sArr(n + 1, 6) Then
              k = k + 1
              Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
              Res(k, 3) = sArr(n, 3): Res(k, 6) = sArr(n, 5)
              Res(k, 4) = sArr(n, 4): Res(k, 5) = sArr(n + 1, 4)
              sArr(n, 5) = 0: sArr(n + 1, 6) = 0
              n = n + 1
            ElseIf sArr(n, 6) <> 0 And sArr(n, 6) = sArr(n + 1, 5) Then
              k = k + 1
              Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
              Res(k, 3) = sArr(n, 3): Res(k, 6) = sArr(n, 5)
              Res(k, 4) = sArr(n + 1, 4): Res(k, 5) = sArr(n, 4)
              sArr(n, 6) = 0: sArr(n + 1, 5) = 0
              n = n + 1
            End If
          End If
        End If
      Next n
      
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
      
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST <> 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("Loc")
    If k Then .Range("A6:F6").Resize(k) = Res
  End With
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Code chỉ dùng cho file của bạn
Kiểm tra lại
Mã: 
Sub Tach()
  Dim sArr(), Res()
  Dim i As Long, k As Long, sRowNo As Long, fRow As Long
  Dim jNhieu As Byte, jDU As Byte
  Dim ST As Double, tkNo As String, tkCo As String, tkDU As String

  Application.ScreenUpdating = False
  With Sheets("Loc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("A6:F" & i).ClearContents
  End With

  With Sheets("Goc")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
  End With
  ReDim Res(1 To UBound(sArr), 1 To 6)

  For i = 2 To UBound(sArr) - 1
    If sArr(i, 2) <> sArr(i - 1, 2) Then fRow = i
    If sArr(i, 5) <> 0 Then
      sRowNo = sRowNo + 1
      tkNo = sArr(i, 4)
    ElseIf sArr(i, 6) <> 0 Then
      tkCo = sArr(i, 4)
    End If
   
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      For n = fRow To i - 1
        If sArr(n, 1) & sArr(n, 2) & sArr(n, 3) = _
            sArr(n + 1, 1) & sArr(n + 1, 2) & sArr(n + 1, 3) Then
          If sArr(n, 4) <> sArr(n + 1, 4) Then
            If sArr(n, 5) <> 0 And sArr(n, 5) = sArr(n + 1, 6) Then
              k = k + 1
              Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
              Res(k, 3) = sArr(n, 3): Res(k, 6) = sArr(n, 5)
              Res(k, 4) = sArr(n, 4): Res(k, 5) = sArr(n + 1, 4)
              sArr(n, 5) = 0: sArr(n + 1, 6) = 0
              n = n + 1
            ElseIf sArr(n, 6) <> 0 And sArr(n, 6) = sArr(n + 1, 5) Then
              k = k + 1
              Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
              Res(k, 3) = sArr(n, 3): Res(k, 6) = sArr(n, 5)
              Res(k, 4) = sArr(n + 1, 4): Res(k, 5) = sArr(n, 4)
              sArr(n, 6) = 0: sArr(n + 1, 5) = 0
              n = n + 1
            End If
          End If
        End If
      Next n
     
      If sRowNo = 1 Then
        jNhieu = 6:        jDU = 4:        tkDU = tkNo
      Else
        jNhieu = 5:        jDU = 5:        tkDU = tkCo
      End If
      sRowNo = 0
     
      For n = fRow To i
        ST = sArr(n, jNhieu)
        If ST <> 0 Then
          k = k + 1
          Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
          Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
          Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
        End If
      Next n
    End If
  Next i

  With Sheets("Loc")
    If k Then .Range("A6:F6").Resize(k) = Res
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ, e cám ơn anh.

Nhưng do cấu trúc dữ liệu kế toán này e thấy nhiều nghiệp vụ này khác thông thường khi chuyển không hiện lên, anh xem giúp em.

Cái chốt được số tiền khi chuyển đổi bằng dữ liệu gốc, tổng số tiền sum cột E và cột F = 6.629.603.972.283 VND.
Số liệu chuyển đổi đang là 6.665.839.236.489 VND

Cám ơn anh rất nhiều à.

214752
 
satthuvae đã viết:
Dạ, e cám ơn anh.

Nhưng do cấu trúc dữ liệu kế toán này e thấy nhiều nghiệp vụ này khác thông thường khi chuyển không hiện lên, anh xem giúp em.

Cái chốt được số tiền khi chuyển đổi bằng dữ liệu gốc, tổng số tiền sum cột E và cột F = 6.629.603.972.283 VND.
Số liệu chuyển đổi đang là 6.665.839.236.489 VND

Cám ơn anh rất nhiều à.

View attachment 214752
Nhấp chuột vào đây để mở rộng...
Bạn sort dữ liệu theo cột ngày tháng va số chứng từ rồi chạy code xem sao
 
Mình cần tạo 1 file excel để tính tiền điện sinh hoạt và tiền nước cho từng phòng trọ, mỗi phòng có công tơ phụ, đồng hồ nước phụ. Tuy nhiên có 1 bơm để bơm nước sinh hoạt. Trước nay vẫn làm thủ công, tính chỉ sổ đầu và chỉ số cuối, tính theo lũy kế tiền điện như nhà nước quy định. Có bạn nào giúp với Giải pháp excel để có thể tính đúng và đủ cho người thuê nhà được ko. Rất smong các bạn giúp đỡ. Xin cám ơn. Ly
 

File đính kèm

  • tinh tien dien.xlsx
    16.6 KB · Đọc: 2
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

phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
2
Trả lời
28
Đọc
385
VetMini
V
tby211
Lỗi 1004 vba khi tách file trắc nghiệm sang excel
Trả lời
0
Đọc
17
tby211
tby211
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
6
Đọc
142
NguyenthiH
NguyenthiH
test1986
  • Question
HELP! Sử dụng combobox để cập nhật dữ liệu trong file Excel
Trả lời
17
Đọc
508
ngochienbmt
N
N
Hàm if, lọc dữ liệu trùng
Trả lời
6
Đọc
6K
OANHMAI123
O
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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