Tạo bảng dữ liệu từ 1 bảng có sẵn

[hadoan-pap]

Em chào Anh/Chị

Dạ. Em có 1 job nhỏ khá rắc rối mà e chưa làm dc trong việc tạo 1 bảng dữ lieu mong muốn từ 1 bang có sẵn như file đính kèm . E xin trình bày như dưới ạ.

Bảng nguồn là Sheet2, e muốn từ ấn nút macro để tạo ra bang ở Sheet1 từ dữ lieu bang Sheet2.

- Các cột có thể thay đổi do số lượng item mình add vào
- Với các iteam mà hang "SL" của nó để trống hoặc N/A thì sẽ bỏ qua, k add sang bảng ở Sheet1
- Cột A ở bang Sheet1, nó sẽ dc cộng dồn theo các giá trị của hang "SL" bên Sheet 2... bắt đầu = 0... Cứ 2 hang có giá trị như nhau sẽ thể hiện 1 giá trị ạ.

Rất mong các thầy và Anh/Chị giúp em bài toán này ạ.

E xin cảm ơn!

 

[snow25]

Em chào Anh/Chị

Dạ. Em có 1 job nhỏ khá rắc rối mà e chưa làm dc trong việc tạo 1 bảng dữ lieu mong muốn từ 1 bang có sẵn như file đính kèm . E xin trình bày như dưới ạ.

Bảng nguồn là Sheet2, e muốn từ ấn nút macro để tạo ra bang ở Sheet1 từ dữ lieu bang Sheet2.

- Các cột có thể thay đổi do số lượng item mình add vào
- Với các iteam mà hang "SL" của nó để trống hoặc N/A thì sẽ bỏ qua, k add sang bảng ở Sheet1
- Cột A ở bang Sheet1, nó sẽ dc cộng dồn theo các giá trị của hang "SL" bên Sheet 2... bắt đầu = 0... Cứ 2 hang có giá trị như nhau sẽ thể hiện 1 giá trị ạ.

Rất mong các thầy và Anh/Chị giúp em bài toán này ạ.

E xin cảm ơn!

Bạn xem cái này nhé.

Sub Button1_Click()
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(3, 1000).End(xlToLeft).Column - 1
        arr = .Range("B3:b5").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For i = 2 To UBound(arr, 2)
            If Len(arr(2, i)) And UCase(arr(2, i)) <> "N/A" Then
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i)
               tong = tong + arr(2, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i)
            End If
        Next i
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True
End Sub

 

[hadoan-pap]

Bạn xem cái này nhé.

Sub Button1_Click()
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(3, 1000).End(xlToLeft).Column - 1
        arr = .Range("B3:b5").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For i = 2 To UBound(arr, 2)
            If Len(arr(2, i)) And UCase(arr(2, i)) <> "N/A" Then
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i)
               tong = tong + arr(2, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i)
            End If
        Next i
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True
End Sub

Snow ơi cảm ơn cậu rất nhiều.. Gần đúng với ý tớ mong muốn rồi, nó chỉ còn 1-2 chỗ , tớ xin miêu tả như dưới nhé :

- Tớ muốn khi đưa giá trị hang "%" ở Sheet2 sang thì nó k tính chia %, nó chỉ loại bỏ dấu % và bê nguyên gia trị đó sang. Ví dụ : 17.5% khi đưa sang Sheet1 sẽ là 17.5
- Khi tớ thay đổi giá trị ô N/A của Sheet2 thành 1 giá trị khác thì nó chạy lỗi như file đính kèm.

Cậu check giúp tớ nhé.

Cảm ơn cậu rất nh!

 

[snow25]

Snow ơi cảm ơn cậu rất nhiều.. Gần đúng với ý tớ mong muốn rồi, nó chỉ còn 1-2 chỗ , tớ xin miêu tả như dưới nhé :

- Tớ muốn khi đưa giá trị hang "%" ở Sheet2 sang thì nó k tính chia %, nó chỉ loại bỏ dấu % và bê nguyên gia trị đó sang. Ví dụ : 17.5% khi đưa sang Sheet1 sẽ là 17.5
- Khi tớ thay đổi giá trị ô N/A của Sheet2 thành 1 giá trị khác thì nó chạy lỗi như file đính kèm.

Cậu check giúp tớ nhé.

Cảm ơn cậu rất nh!

Bạn sửa lại xem đúng không.

Sub Button1_Click()
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(3, 1000).End(xlToLeft).Column - 1
        arr = .Range("B3:b5").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For i = 2 To UBound(arr, 2)
            If Len(arr(2, i)) And UCase(arr(2, i)) <> "N/A" Then
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i) * 100
               tong = tong + arr(2, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i) * 100
            End If
        Next i
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True

End Sub

 

[hadoan-pap]

Bạn sửa lại xem đúng không.

Sub Button1_Click()
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(3, 1000).End(xlToLeft).Column - 1
        arr = .Range("B3:b5").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For i = 2 To UBound(arr, 2)
            If Len(arr(2, i)) And UCase(arr(2, i)) <> "N/A" Then
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i) * 100
               tong = tong + arr(2, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i) * 100
            End If
        Next i
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True

End Sub

Hi Snow.

Quá OK rồi cậu.. Tớ cảm ơn cậu nh nhé… Cậu giúp tớ 1 lần nữa với file chuẩn tớ gửi như đính kèm nhé

File chuẩn thì bang dữ lieu ở Sheet2 nó như đính kèm… Tớ muốn 3 nút tương đương với 3 option "Dosmetic", "Export", "Total"... ấn mỗi nút thì nó sẽ lấy dữ lieu tương ứng ở Sheet2 và đưa sang Sheet1 tạo thành bang dữ lieu tương ứng.

Ở mỗi bang đều có cột Total ( chữ "Total" này là fix ), nó sẽ không move giá trị cột Total này sang Sheet1, user có thể chèn them các item trc cột Total để chạy. Khi đưa giá trị sang Sheet1 nó sẽ không đưa cột Total này sang.

Trong code của cậu b=2: a=1 có nghĩa là gì vậy?

1 lần nữa cảm ơn cậu rất nhiều.

 

[huuthang_bd]

Yêu cầu này thì chỉ cần công thức và data validation list là xong ngay.

Hi Snow.

Quá OK rồi cậu.. Tớ cảm ơn cậu nh nhé… Cậu giúp tớ 1 lần nữa với file chuẩn tớ gửi như đính kèm nhé

File chuẩn thì bang dữ lieu ở Sheet2 nó như đính kèm… Tớ muốn 3 nút tương đương với 3 option "Dosmetic", "Export", "Total"... ấn mỗi nút thì nó sẽ lấy dữ lieu tương ứng ở Sheet2 và đưa sang Sheet1 tạo thành bang dữ lieu tương ứng.

Ở mỗi bang đều có cột Total ( chữ "Total" này là fix ), nó sẽ không move giá trị cột Total này sang Sheet1, user có thể chèn them các item trc cột Total để chạy. Khi đưa giá trị sang Sheet1 nó sẽ không đưa cột Total này sang.

Trong code của cậu b=2: a=1 có nghĩa là gì vậy?

1 lần nữa cảm ơn cậu rất nhiều.

Hôm trước có một bạn lên truyền hình mà nói nửa Việt nửa Anh bị cộng đồng phản ứng quá trời. Bạn này không biết ngoài Việt và Anh còn chiêm thêm tiếng gì nữa.

 

[hadoan-pap]

Yêu cầu này thì chỉ cần công thức và data validation list là xong ngay.

Hôm trước có một bạn lên truyền hình mà nói nửa Việt nửa Anh bị cộng đồng phản ứng quá trời. Bạn này không biết ngoài Việt và Anh còn chiêm thêm tiếng gì nữa.

Dạ em xin lỗi, lần sau e sẽ chú ý hơn ạ.

Tại quen tay nên viết anh ah.

 

[snow25]

Hi Snow.

Quá OK rồi cậu.. Tớ cảm ơn cậu nh nhé… Cậu giúp tớ 1 lần nữa với file chuẩn tớ gửi như đính kèm nhé

File chuẩn thì bang dữ lieu ở Sheet2 nó như đính kèm… Tớ muốn 3 nút tương đương với 3 option "Dosmetic", "Export", "Total"... ấn mỗi nút thì nó sẽ lấy dữ lieu tương ứng ở Sheet2 và đưa sang Sheet1 tạo thành bang dữ lieu tương ứng.

Ở mỗi bang đều có cột Total ( chữ "Total" này là fix ), nó sẽ không move giá trị cột Total này sang Sheet1, user có thể chèn them các item trc cột Total để chạy. Khi đưa giá trị sang Sheet1 nó sẽ không đưa cột Total này sang.

Trong code của cậu b=2: a=1 có nghĩa là gì vậy?

1 lần nữa cảm ơn cậu rất nhiều.

Chạy thử cái này.

Sub chuyendulieu(ByVal dk As String)
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(1, 1000).End(xlToLeft).Column
        arr = .Range("a1:a13").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For j = 2 To UBound(arr)
            If arr(j, 1) = dk Then
        For i = 3 To UBound(arr, 2)
            If Len(arr(j, i)) And UCase(arr(j, i)) <> "N/A" Then
          
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = Format(arr(j + 1, i) * 100, "0,00")
               tong = tong + arr(j, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = Format(arr(j + 1, i) * 100, "0,00")
          
            End If
        Next i
            Exit For
           End If
        Next j
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True

End Sub
Sub Domestic()
     chuyendulieu "Domestic"
End Sub
Sub Export()
    chuyendulieu "Export"
End Sub
Sub Total()
    chuyendulieu "Total"
End Sub

 

[hadoan-pap]

Bạn sửa lại xem đúng không.

Sub Button1_Click()
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(3, 1000).End(xlToLeft).Column - 1
        arr = .Range("B3:b5").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For i = 2 To UBound(arr, 2)
            If Len(arr(2, i)) And UCase(arr(2, i)) <> "N/A" Then
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i) * 100
               tong = tong + arr(2, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = arr(3, i) * 100
            End If
        Next i
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True

End Sub

Hi Snow.

Tớ mới chỉnh sửa lại như file đính kèm… Nút ấn cho phần "Dosmetic" tớ đã sửa lại xong.. Nhưng nút cho phần "Export" thì chạy nó đang bị lỗi như trong file... Cậu check giúp tớ với nhé.

Ah còn chút nữa là tớ không muốn bê dữ lieu cột "Total" từ Sheet2 sang Sheet1, tớ có add them câu lệnh để check nhưng nó vẫn chưa chạy dc cậu ạ.

Tớ cảm ơn nhe!

Bài đã được tự động gộp: 17/6/19

Chạy thử cái này.

Sub chuyendulieu(ByVal dk As String)
Application.ScreenUpdating = False
     Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
     b = 2: a = 1
     With Sheets("sheet2")
        lc = .Cells(1, 1000).End(xlToLeft).Column
        arr = .Range("a1:a13").Resize(, lc).Value
        ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
     End With
        arr1(1, 1) = "ALL"
        arr1(2, 1) = tong
        For j = 2 To UBound(arr)
            If arr(j, 1) = dk Then
        For i = 3 To UBound(arr, 2)
            If Len(arr(j, i)) And UCase(arr(j, i)) <> "N/A" Then
          
               a = a + 1
               arr1(1, a) = arr(1, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = Format(arr(j + 1, i) * 100, "0,00")
               tong = tong + arr(j, i)
               b = b + 1
               arr1(b, 1) = tong
               arr1(b, a) = Format(arr(j + 1, i) * 100, "0,00")
          
            End If
        Next i
            Exit For
           End If
        Next j
        b = b + 1
        arr1(b, 1) = tong
      With Sheets("sheet1")
           .Cells.ClearContents
           .Range("A1").Resize(b, a).Value = arr1
      End With
Application.ScreenUpdating = True

End Sub
Sub Domestic()
     chuyendulieu "Domestic"
End Sub
Sub Export()
    chuyendulieu "Export"
End Sub
Sub Total()
    chuyendulieu "Total"
End Sub

Cảm ơn cậu đoạn code này nhé. Tớ sẽ giữ lại study....

Nhưng tớ muốn chia thành 3 nút như trong file... Cậu check giúp tớ xem nút "Export" tại sao nó k chạy cậu nhé.

Cảm ơn cậu nhiều!

 

[snow25]

Hi Snow.

Tớ mới chỉnh sửa lại như file đính kèm… Nút ấn cho phần "Dosmetic" tớ đã sửa lại xong.. Nhưng nút cho phần "Export" thì chạy nó đang bị lỗi như trong file... Cậu check giúp tớ với nhé.

Ah còn chút nữa là tớ không muốn bê dữ lieu cột "Total" từ Sheet2 sang Sheet1, tớ có add them câu lệnh để check nhưng nó vẫn chưa chạy dc cậu ạ.

Tớ cảm ơn nhe!

Bài đã được tự động gộp: 17/6/19

Cảm ơn cậu đoạn code này nhé. Tớ sẽ giữ lại study....

Nhưng tớ muốn chia thành 3 nút như trong file... Cậu check giúp tớ xem nút "Export" tại sao nó k chạy cậu nhé.

Cảm ơn cậu nhiều!

Bạn xem file.

 

[huuthang_bd]

Viết (có thời gian xem lại và sửa chữa) còn khó vậy thì nói chắc là không thể

 

[hadoan-pap]

Bạn xem file.

Snow ơi code nó chạy nhầm cậu ạ.. Nó chạy lấy dữ lieu đang bị sai cả 3 nút.

Tớ muốn lấy phần dữ lieu ở Sheet2 được bôi màu xanh ( MP và MP% ) cậu ạ.

Còn cái nữa là cột "Total" ở sheet2 thì nó bỏ, không đưa sang Sheet1.

Hơn nữa, tớ k muốn dung sub Call để gọi…. tớ muốn chia thành 3 nút với 3 đoạn code như nhau, chỉ chỉnh sửa các số sao cho khớp với bang data table bên Sheet2. Vì về sau tớ sẽ expand ra them nên cần như vậy cậu ạ.

Làm phiền cậu quá… Cậu xem và sửa them giúp tớ nhé!

 

[hadoan-pap]

Bạn xem file.

Hi Snow.

Tớ có sửa dc 2 nút ổn rồi , nhưng chỉ có nút "Export" là k hiểu sao bị lỗi.

Cậu check giúp tớ nút Export với nhé.

Hơn nữa là tớ k muốn copy cột "Total" từ Sheet2 sang, tớ đã có add them code nhưng nó vẫn chưa chạy được.

Cảm ơn cậu!

 

[hadoan-pap]

Hi Snow!

Cảm ơn cậu nhé tớ tự sửa được rồi.

Cảm ơn cậu rất nhiều về đoạn code

 

[hadoan-pap]

Hi @snow25

Rất xin lỗi cậu. Cậu cho tớ hỏi nhờ them 1 chút xíu nữa nhé.

Hôm trước cậu cho tớ xin đoạn code để đồng bộ dữ lieu từ Sheet2 sang Sheet1 như file đính kèm. Giờ tớ muốn đồng bộ Item từ Sheet2 sang Sheet1 nhưng nó đồng bộ theo cả màu Cell ( Tức là cell ở Sheet2 đang được bôi màu vàng thì đồng bộ sang Sheet1 nó cũng phải được bôi màu vàng )

Cậu check giúp tớ đoạn code bên dưới xem cần sửa them chỗ nào k với.

Cảm ơn cậu.

Sheet1.Range("A1:AA100").ClearContents
Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
b = 2: a = 1
With Sheets("sheet2")
lc = .Cells(1, 1000).End(xlToLeft).Column - 1
arr = .Range("B1:b5").Resize(, lc).Value
ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
End With
arr1(1, 1) = "ALL"
arr1(2, 1) = tong
For i = 2 To UBound(arr, 2)
If Len(arr(4, i)) And UCase(arr(4, i)) <> "N/A" Then
If arr(1, i) <> "Total" Then
a = a + 1
arr1(1, a) = arr(1, i)
b = b + 1
arr1(b, 1) = tong
arr1(b, a) = arr(5, i) * 100
tong = tong + arr(4, i)
b = b + 1
arr1(b, 1) = tong
arr1(b, a) = arr(5, i) * 100
End If
End If
Next i
b = b + 1
arr1(b, 1) = tong
With Sheets("sheet1")
.Cells.ClearContents
.Range("A1").Resize(b, a).Value = arr1
End With

 

[snow25]

Hi @snow25

Rất xin lỗi cậu. Cậu cho tớ hỏi nhờ them 1 chút xíu nữa nhé.

Hôm trước cậu cho tớ xin đoạn code để đồng bộ dữ lieu từ Sheet2 sang Sheet1 như file đính kèm. Giờ tớ muốn đồng bộ Item từ Sheet2 sang Sheet1 nhưng nó đồng bộ theo cả màu Cell ( Tức là cell ở Sheet2 đang được bôi màu vàng thì đồng bộ sang Sheet1 nó cũng phải được bôi màu vàng )

Cậu check giúp tớ đoạn code bên dưới xem cần sửa them chỗ nào k với.

Cảm ơn cậu.

Sheet1.Range("A1:AA100").ClearContents
Dim arr, lc As Long, arr1, i As Long, j As Long, a As Long, b As Long, tong As Long
b = 2: a = 1
With Sheets("sheet2")
lc = .Cells(1, 1000).End(xlToLeft).Column - 1
arr = .Range("B1:b5").Resize(, lc).Value
ReDim arr1(1 To UBound(arr, 2) * 2 + 1, 1 To UBound(arr, 2))
End With
arr1(1, 1) = "ALL"
arr1(2, 1) = tong
For i = 2 To UBound(arr, 2)
If Len(arr(4, i)) And UCase(arr(4, i)) <> "N/A" Then
If arr(1, i) <> "Total" Then
a = a + 1
arr1(1, a) = arr(1, i)
b = b + 1
arr1(b, 1) = tong
arr1(b, a) = arr(5, i) * 100
tong = tong + arr(4, i)
b = b + 1
arr1(b, 1) = tong
arr1(b, a) = arr(5, i) * 100
End If
End If
Next i
b = b + 1
arr1(b, 1) = tong
With Sheets("sheet1")
.Cells.ClearContents
.Range("A1").Resize(b, a).Value = arr1
End With

Mình chỉnh 1 cái bạn chỉnh 3 cái kia nhé.

 

[hadoan-pap]

Mình chỉnh 1 cái bạn chỉnh 3 cái kia nhé.

Hi @snow25
Cảm ơn cậu rất nhiều