xử lý code trong vba (3 người xem)

[caonguyen89]

hiện tại mình đang muốn viết 1 đoạn code để có thể copy dữ liệu từ các file excel khác nhau vào file tổng hợp khi chạy code báo lỗi không tìm thấy file
code như sau :

Sub nhapdulieu()
Dim total As Worksheet, sh As Worksheet
Dim wk As Workbook
Dim strFolderpath As String
Dim selectedFile As Variant
Dim ifileNum As Integer, ilastrowreport As Integer, inumberofrowtopaste As Integer
Dim Rvitri As Range, Rpartcode As Range, RMAKHUON As Range, rsoluong As Range
Dim strfilename As String
Dim icurrentlasrow As Integer, irowstarttopaste As Integer


Set total = ActiveWorkbook.Sheets("total")

strFolderpath = ActiveWorkbook.Path
ChDrive strFoldepath
ChDir strFolderpath

selectedFile = Application.GetOpenFilename( _
File fiter:="Excel File(*.xls),*.xlsx", MultiSelect:=True)

For ifileNum = ibound(selectedFile) To unbound(selectedFile)
strfilename = selectedFile(ifilename)

Set wk = Workbooks.Open(strfilename)
For Each sh In wk.Sheets
If sh.Name Like "*-giao" Then
With sh
ilastrowtotal = .Range("a" & Rows.Count).End(xlUp).Row
inummberofrowtopaste = ilastrowreport - 2 + 1

Set Rvitri = .Range("A2:a" & ilastrowtotal)
Set Rpartcode = .Range("b2:b" & ilastrowtotal)
Set Rpartcode1 = .Range("C2:C" & ilastrowtotal)
Set RMAKHUON = .Range("D2" & ilastrowtotal)
Set rsoluong = .Range("e2:e" & ilastrowtotal)

With master
icurrentlasrow = .Range("A" & Rows.Count).End(xlUp).Row
irowstarttopaste = icurrentlasrow + 1

.Range("a" & irowstarttopaste).Resize(inumberofrowstopaste, 1) = Rvitri.Value2
.Range("b" & irowstarttopaste).Resize(inumberofrowstopaste, 1) = Rpartcode.Value2
.Range("c" & irowstarttopaste).Resize(inumberofrowstopaste, 1) = Rpartcode1.Value2
.Range("d" & irowstarttopaste).Resize(inumberofrowstopaste, 1) = RMAKHUON.Value2
.Range("e" & irowstarttopaste).Resize(inumberofrowstopaste, 1) = rsoluong.Value2
End With

End With
End If
Next sh
wk.Close
Next



End Sub

mình đính kèm file tổng hợp và 1 file mẫu

mong anh/chị nào rõ chỉ bảo

 

[♫ђöล♥ßล†♥†µ♫]

hiện tại mình đang muốn viết 1 đoạn code để có thể copy dữ liệu từ các file excel khác nhau vào file tổng hợp khi chạy code báo lỗi không tìm thấy file
mong anh/chị nào rõ chỉ bảo

Không biết ai chỉ cho Bạn cách đặt tên biến nó khủng khiếp quá vậy
Do nó quá hoành tráng nên chẳng biết cái nào đúng cái nào sai nữa
Mình sửa tàm tạm thôi nha

Sub nhapdulieu()
    Dim total As Worksheet, sh As Worksheet
    Dim wk As Workbook
    Dim strFolderPath As String
    Dim selectedFile As Variant
    Dim ifileNum As Integer, ilastrowreport As Integer, inumberofrowtopaste As Integer
    Dim Rvitri As Range, Rpartcode As Range, RMAKHUON As Range, rsoluong As Range
    Dim strFileName As String
    Dim icurrentlasrow As Integer, inummberofrowtopaste As Integer, ilastrowtotal As Integer
Application.ScreenUpdating = False
Set total = ActiveWorkbook.Sheets("total")
On Error GoTo NoFile
selectedFile = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
For ifileNum = LBound(selectedFile) To UBound(selectedFile)
    strFileName = selectedFile(ifileNum)
    Set wk = Workbooks.Open(strFileName, False)
    For Each sh In wk.Sheets
        If sh.Name Like "*GIAO" Then
            With sh
                ilastrowtotal = .Range("a" & Rows.Count).End(xlUp).Row
                inummberofrowtopaste = ilastrowtotal - 4 + 1
                Set Rvitri = .Range("A4:A" & ilastrowtotal)
                Set Rpartcode = .Range("B4:B" & ilastrowtotal)
                Set Rpartcode1 = .Range("C4:C" & ilastrowtotal)
                Set RMAKHUON = .Range("D4:D" & ilastrowtotal)
                Set rsoluong = .Range("E4:eE" & ilastrowtotal)
                With total
                    icurrentlasrow = .Range("A" & Rows.Count).End(xlUp).Row
                    irowstarttopaste = icurrentlasrow + 1
                    .Range("A" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = Rvitri.Value2
                    .Range("B" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = Rpartcode.Value2
                    .Range("C" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = Rpartcode1.Value2
                    .Range("D" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = RMAKHUON.Value2
                    .Range("E" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = rsoluong.Value2
                End With
            End With
        End If
    Next sh
    wk.Close False
Next
NoFile:
Application.ScreenUpdating = True
End Sub

Viết theo kiểu của Mình nó như rứa

Sub ImportData()
    Dim Master As Worksheet, sh As Worksheet, wk As Workbook, strFileName As String
    Dim Arr As Variant, v As Integer, Rng As Range
    Dim ErowC As Long, Np As Long, ErowP As Long
    Application.ScreenUpdating = False
    Set Master = ActiveWorkbook.Sheets("total")
    On Error GoTo NoFile
    Arr = Application.GetOpenFilename( _
            filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
    For v = LBound(Arr) To UBound(Arr)
        strFileName = Arr(v)
        Set wk = Workbooks.Open(strFileName, False)
        For Each sh In wk.Sheets
            If sh.Name Like "*GIAO" Then
                With sh
                    ErowP = Master.Range("A" & Rows.Count).End(xlUp).Row + 1
                    ErowC = .Range("A" & Rows.Count).End(xlUp).Row
                    Set Rng = .Range("A4:A" & ErowC).Resize(, 5)
                    Np = ErowC - 4 + 1: Master.Range("A" & ErowP).Resize(Np, 5) = Rng.Value2
                End With
            End If
        Next sh
        wk.Close False
    Next
    MsgBox "Qua trinh lay du lieu hoan thanh   "
NoFile:
    Exit Sub
    Application.ScreenUpdating = True
End Sub

 

[caonguyen89]

Không biết ai chỉ cho Bạn cách đặt tên biến nó khủng khiếp quá vậy
Do nó quá hoành tráng nên chẳng biết cái nào đúng cái nào sai nữa
Mình sửa tàm tạm thôi nha

Sub nhapdulieu()
    Dim total As Worksheet, sh As Worksheet
    Dim wk As Workbook
    Dim strFolderPath As String
    Dim selectedFile As Variant
    Dim ifileNum As Integer, ilastrowreport As Integer, inumberofrowtopaste As Integer
    Dim Rvitri As Range, Rpartcode As Range, RMAKHUON As Range, rsoluong As Range
    Dim strFileName As String
    Dim icurrentlasrow As Integer, inummberofrowtopaste As Integer, ilastrowtotal As Integer
Application.ScreenUpdating = False
Set total = ActiveWorkbook.Sheets("total")
On Error GoTo NoFile
selectedFile = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
For ifileNum = LBound(selectedFile) To UBound(selectedFile)
    strFileName = selectedFile(ifileNum)
    Set wk = Workbooks.Open(strFileName, False)
    For Each sh In wk.Sheets
        If sh.Name Like "*GIAO" Then
            With sh
                ilastrowtotal = .Range("a" & Rows.Count).End(xlUp).Row
                inummberofrowtopaste = ilastrowtotal - 4 + 1
                Set Rvitri = .Range("A4:A" & ilastrowtotal)
                Set Rpartcode = .Range("B4:B" & ilastrowtotal)
                Set Rpartcode1 = .Range("C4:C" & ilastrowtotal)
                Set RMAKHUON = .Range("D4:D" & ilastrowtotal)
                Set rsoluong = .Range("E4:eE" & ilastrowtotal)
                With total
                    icurrentlasrow = .Range("A" & Rows.Count).End(xlUp).Row
                    irowstarttopaste = icurrentlasrow + 1
                    .Range("A" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = Rvitri.Value2
                    .Range("B" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = Rpartcode.Value2
                    .Range("C" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = Rpartcode1.Value2
                    .Range("D" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = RMAKHUON.Value2
                    .Range("E" & irowstarttopaste).Resize(inummberofrowtopaste, 1) = rsoluong.Value2
                End With
            End With
        End If
    Next sh
    wk.Close False
Next
NoFile:
Application.ScreenUpdating = True
End Sub

Viết theo kiểu của Mình nó như rứa

Sub ImportData()
    Dim Master As Worksheet, sh As Worksheet, wk As Workbook, strFileName As String
    Dim Arr As Variant, v As Integer, Rng As Range
    Dim ErowC As Long, Np As Long, ErowP As Long
    Application.ScreenUpdating = False
    Set Master = ActiveWorkbook.Sheets("total")
    On Error GoTo NoFile
    Arr = Application.GetOpenFilename( _
            filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
    For v = LBound(Arr) To UBound(Arr)
        strFileName = Arr(v)
        Set wk = Workbooks.Open(strFileName, False)
        For Each sh In wk.Sheets
            If sh.Name Like "*GIAO" Then
                With sh
                    ErowP = Master.Range("A" & Rows.Count).End(xlUp).Row + 1
                    ErowC = .Range("A" & Rows.Count).End(xlUp).Row
                    Set Rng = .Range("A4:A" & ErowC).Resize(, 5)
                    Np = ErowC - 4 + 1: Master.Range("A" & ErowP).Resize(Np, 5) = Rng.Value2
                End With
            End If
        Next sh
        wk.Close False
    Next
    MsgBox "Qua trinh lay du lieu hoan thanh   "
NoFile:
    Exit Sub
    Application.ScreenUpdating = True
End Sub

cám ơn bạn đã hỗ trợ, mình học theo video thôi k có ai dạy chính thức cả ;(( vì không có lớp nào gần nhà tổ chức dạy học VBA

mình cần hỗ trợ thêm 1 điểm này nữa bạn xem có được không nhé
do dữ liệu mình muốn copy theo dữ liệu ở cột B các dòng có dữ liệu nếu không có dữ liệu ở cột B sẽ không coppy nữa

 

[♫ђöล♥ßล†♥†µ♫]

cám ơn bạn đã hỗ trợ, mình học theo video thôi k có ai dạy chính thức cả ;(( vì không có lớp nào gần nhà tổ chức dạy học VBA

mình cần hỗ trợ thêm 1 điểm này nữa bạn xem có được không nhé
do dữ liệu mình muốn copy theo dữ liệu ở cột B các dòng có dữ liệu nếu không có dữ liệu ở cột B sẽ không coppy nữa

Bạn thêm

         With Master
            Erow = .Range("A" & Rows.Count).End(xlUp).Row + 1
            .Range("B" & ErowP & ":B" & Erow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With

vào dưới dòng

wk.Close False

 

[caonguyen89]

Bạn thêm

         With Master
            Erow = .Range("A" & Rows.Count).End(xlUp).Row + 1
            .Range("B" & ErowP & ":B" & Erow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With

vào dưới dòng

wk.Close False

cám ơn bạn

cho mình hỏi ý nghĩa của đoạn lệnh này được không

With sh ErowP = Master.Range("A" & Rows.Count).End(xlUp).Row + 1 ErowC = .Range("A" & Rows.Count).End(xlUp).Row Set Rng = .Range("A4:A" & ErowC).Resize(, 5) Np = ErowC - 4 + 1: Master.Range("A" & ErowP).Resize(Np, 5) = Rng.Value2