Tự động thêm dòng dữ liệu tương ứng

vt01 · 7/4/08

Mình có 1 file ban đầu như file before.xls và , bạn nào giúp mình tạo 1 marco để thực hiện như thuật toán trong chú thích ở sheet3 để cho kết quả như file after.xls

SA_DQ · 7/4/08

Bạn dùng cái con macro này & cho ý kiến!

PHP:

Option Explicit

Sub AddRowsAndCopyData()
 Dim lRow As Long, Zw As Long
 Const iTem5 As String = "ITEM5", iTem2 = "ITEM2"
 Dim Rng As Range
 
 lRow = Sheets("Sheet3").Range("B65432").End(xlUp).Row
 
 For Zw = lRow To 1 Step -1
    If UCase$(Cells(Zw, 2)) = iTem5 Then
        If Rng Is Nothing Then
            Set Rng = Cells(Zw, 2).Offset(1).Resize(3, 1)
        Else
            Set Rng = Union(Rng, Cells(Zw, 2).Offset(1).Resize(3, 1))
        End If
    ElseIf UCase$(Cells(Zw, 2)) = iTem2 Then
        If Rng Is Nothing Then
            Set Rng = Cells(Zw, 2).Offset(1).Resize(2, 1)
        Else
            Set Rng = Union(Rng, Cells(Zw, 2).Offset(1).Resize(2, 1))
        End If
    End If
 Next Zw
 Rng.EntireRow.Insert Shift:=xlDown
 
 lRow = Sheets("Sheet3").Range("B65432").End(xlUp).Row
 For Zw = 2 To lRow
    If UCase$(Cells(Zw, 2)) = iTem5 Then
        With Cells(Zw, 2)
            .Offset(1) = "iTem51":              .Offset(2) = "iTem52"
            .Offset(1, 1).Resize(3, 1) = .Offset(, 1)
            .Offset(3) = "iTem53":              .Offset(2, 1) = 2 * .Offset(2, 1)
            .Offset(2, 2).Resize(2, 1) = 0.1:   .Offset(1, 2) = .Offset(, 2) - 0.2
        
        End With
    ElseIf UCase$(Cells(Zw, 2)) = iTem2 Then
        With Cells(Zw, 2)
            .Offset(1) = "iTem21":              .Offset(2) = "iTem22"
            .Offset(1, 1).Resize(2, 1) = .Offset(, 1)
            .Offset(2, 2) = 0.1:                .Offset(1, 2) = .Offset(, 2) - 0.1
        End With
    End If
 Next Zw
Exit Sub:               End Sub

Lam_A0 · 7/4/08

To vt01: Bài toán của bạn chẳng có tính tổng quát gì cả, mình không nghĩ là số item lại chỉ dừng lại ở con số 10. Quy luật về thêm các item21, 22, 51,... ; giá của chúng cũng bất định quá. Hy vọng bạn có thể phát triển được code của anh SA_DQ cho bài toán thực của mình!
Thân!

vt01 · 8/4/08

Cám ơn SA_DQ nhưng cho mình hỏi là bạn có thể giữ công thức item21, item22, item51, item52, item53 không và hình như bên sheet1 và sheet2 không tự động thêm dòng vào vị trì tương ứng. Mong bạn giúp mình

SA_DQ · 8/4/08

vt01 đã viết:
Cám ơn SA_DQ nhưng cho mình hỏi là bạn có thể giữ công thức item21, item22, item51, item52, item53 không

Chưa rõ chổ này ra răng? Bạn nói 'giữ' là nghĩa làm sao?

& hình như bên sheet1 và sheet2 không tự động thêm dòng vào vị trì tương ứng. Mong bạn giúp mình

Lười quá nha! Một khi bạn chiêm nghiệm mình thực thi dưới đây; bạn sẽ thấy, đáng ra tự thực hiện lấy thì vui hơn!!!

PHP:

Option Explicit
Sub AddRowsIn3Sheet()
 Dim StrC As String, jZ As Byte
 For jZ = 1 To 3
    StrC = "Sheet" & jZ
    AddRowsAndCopyData StrC
 Next jZ
End Sub

PHP:

Sub AddRowsAndCopyData(ShName As String)
 Dim lRow As Long, Zw As Long
 Const iTem5 As String = "ITEM5", iTem2 = "ITEM2"
 Dim Rng As Range
 
 Sheets(ShName).Select      '<<='
 lRow = Range("B65432").End(xlUp).Row '<<='
 
 For Zw = lRow To 1 Step -1
    If UCase$(Cells(Zw, 2)) = iTem5 Then
        If Rng Is Nothing Then
            Set Rng = Cells(Zw, 2).Offset(1).Resize(3, 1)
        Else
            Set Rng = Union(Rng, Cells(Zw, 2).Offset(1).Resize(3, 1))
        End If
    ElseIf UCase$(Cells(Zw, 2)) = iTem2 Then
        If Rng Is Nothing Then
            Set Rng = Cells(Zw, 2).Offset(1).Resize(2, 1)
        Else
            Set Rng = Union(Rng, Cells(Zw, 2).Offset(1).Resize(2, 1))
        End If
    End If
 Next Zw
 Rng.EntireRow.Insert Shift:=xlDown
 
 lRow = Range("B65432").End(xlUp).Row '<<='
 For Zw = 2 To lRow
    If UCase$(Cells(Zw, 2)) = iTem5 Then
        With Cells(Zw, 2)
            .Offset(1) = "iTem51":              .Offset(2) = "iTem52"
            .Offset(1, 1).Resize(3, 1) = .Offset(, 1)
            .Offset(3) = "iTem53":              .Offset(2, 1) = 2 * .Offset(2, 1)
            If ShName = "Sheet3" Then           '<<='
                .Offset(2, 2).Resize(2, 1) = 0.1:
                .Offset(1, 2) = .Offset(, 2) - 0.2
            End If
        End With
    ElseIf UCase$(Cells(Zw, 2)) = iTem2 Then
        With Cells(Zw, 2)
            .Offset(1) = "iTem21":              .Offset(2) = "iTem22"
            .Offset(1, 1).Resize(2, 1) = .Offset(, 1)
            If ShName = "Sheet3" Then           '<<='
                .Offset(2, 2) = 0.1:
                .Offset(1, 2) = .Offset(, 2) - 0.1
            End If
        End With
    End If
 Next Zw
End Sub

vt01 · 8/4/08

À, ý mình nói là công thức tính cột thành tiền sheet3 ở 5 cell tương ứng của item21, item22, item51, item52,item53 đó mà

SA_DQ · 8/4/08

vt01 đã viết:
À, ý mình nói là công thức tính cột thành tiền sheet3 ở 5 cell tương ứng của item21, item22, item51, item52,item53 đó mà

Mình sẽ chỉ hướng dẫn thôi nha;
Bạn thử nhập vô vùng 'C4

5' đủ các ký số & chạy macro này xem sao:

PHP:

Sub GanCT()
 Range("E4") = "=C4*D4":             Range("e5") = "=C5*D5" 
End Sub

Sau khi đã ngâm cứu & thấy vấn đề, thì tiến hành thêm các câu lệnh cần thiết cho Sheet3 nha!
Còn nếu thua thì phải mời mình đi CFC đó

!

vt01 · 8/4/08

Ủa vậy là muốn chèn công thức là phải có Range("ex") = "=Cx*Dx" hả kiểu này chắc chết quá SA_DQ ơi, hình như công thức trên chỉ đúng với item2 nằm ở dòng thứ 3 thôi, chứ nó chạy dòng khác làm sao gán công thức đây SA_DQ????

SA_DQ · 8/4/08

Hà, Hà! Bạn đã bắt đầu suy tìm rồi đó! Xin chúc mừng

Đây là đoạn code mình nhờ bộ thu macro ghi lại khi dùng Fill hand để điền đầy công thức tại cột 'E' của bạn đây.

Mã:

Sub FillHand()
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E21"), Type:=xlFillDefault
    Range("E2:E21").Select
End Sub

Để có thể ghép đoạn code này xài luôn đúng, thí cần thay tham số 21. (21 là dòng cuối cùng của CSDL của bạn

. Và chúng ta đã có số liệu này. Nó trong biến lRow đó. (Bạn thấy dòng lệnh trước vòng lặp For. . . . Next thứ hai không?!
Khi đó đoạn code trên sẽ được sửa lại như sau:

PHP:

 Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E" & lRow), Type:=xlFillDefault
 Range("E2").Select

Đoạn code này bạn đem thêm vô trước dòng End If của

Mã:

           If ShName = "Sheet3" Then           '<<=' 
                .Offset(2, 2) = 0.1: 
                .Offset(1, 2) = .Offset(, 2) - 0.1 
                                                                  '<<='
            End If

xem đúng í chưa!

vt01 · 8/4/08

SA_DQ mình ko tài nào áp cái macro của bạn vào file của mình, mình ngu quá phải nhờ sư phụ chỉ giáo thôi

SA_DQ · 8/4/08

vt01 đã viết:
Mình nhờ sư phụ chỉ giáo thôi

PHP:

Option Explicit


Sub AddRowsIn3Sheet()
 Dim StrC As String, jZ As Byte
 For jZ = 1 To 3
    StrC = "Sheet" & jZ
    AddRowsAndCopyData StrC
 Next jZ
End Sub


Sub AddRowsAndCopyData(ShName As String)
 Dim lRow As Long, Zw As Long
 Const iTem5 As String = "ITEM5", iTem2 = "ITEM2"
 Dim Rng As Range
 
 Sheets(ShName).Select      '<<='
 lRow = Range("B65432").End(xlUp).Row '<<='
 
 For Zw = lRow To 1 Step -1
    If UCase$(Cells(Zw, 2)) = iTem5 Then
        If Rng Is Nothing Then
            Set Rng = Cells(Zw, 2).Offset(1).Resize(3, 1)
        Else
            Set Rng = Union(Rng, Cells(Zw, 2).Offset(1).Resize(3, 1))
        End If
    ElseIf UCase$(Cells(Zw, 2)) = iTem2 Then
        If Rng Is Nothing Then
            Set Rng = Cells(Zw, 2).Offset(1).Resize(2, 1)
        Else
            Set Rng = Union(Rng, Cells(Zw, 2).Offset(1).Resize(2, 1))
        End If
    End If
 Next Zw
 Rng.EntireRow.Insert Shift:=xlDown
 
 lRow = Range("B65432").End(xlUp).Row '<<='
 For Zw = 2 To lRow
    If UCase$(Cells(Zw, 2)) = iTem5 Then
        With Cells(Zw, 2)
            .Offset(1) = "iTem51":              .Offset(2) = "iTem52"
            .Offset(1, 1).Resize(3, 1) = .Offset(, 1)
            .Offset(3) = "iTem53":              .Offset(2, 1) = 2 * .Offset(2, 1)
            If ShName = "Sheet3" Then           '<<='
                .Offset(2, 2).Resize(2, 1) = 0.1:
                .Offset(1, 2) = .Offset(, 2) - 0.2
            End If
        End With
    ElseIf UCase$(Cells(Zw, 2)) = iTem2 Then
        With Cells(Zw, 2)
            .Offset(1) = "iTem21":              .Offset(2) = "iTem22"
            .Offset(1, 1).Resize(2, 1) = .Offset(, 1)
            If ShName = "Sheet3" Then           '<<='
                .Offset(2, 2) = 0.1:
                .Offset(1, 2) = .Offset(, 2) - 0.1
                Range("E2").Select
                Selection.AutoFill Destination:=Range("E2:E" & lRow), _
                    Type:=xlFillDefault
            End If
        End With
    End If
 Next Zw
End Sub

Tự động thêm dòng dữ liệu tương ứng

vt01

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

Lam_A0

Thành viên hoạt động

vt01

Thành viên mới

SA_DQ

/(hông là gì!

vt01

Thành viên mới

SA_DQ

/(hông là gì!

vt01

Thành viên mới

SA_DQ

/(hông là gì!

vt01

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

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

Facebook

Group

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