Check lỗi macro (1 người xem)

[881516]

hello mọi người,
Mình có macro như dưới dùng để import dữ liệu từ nhiều file excel lại 1 file, chạy ok nhưng hiện mình phát hiện ra 1 bug nhỏ.

Nhờ mọi người có time rảnh check giúp mình.

Ví dụ
Copy ô dữ liệu từ cột A->S của file 1,2,3,4 vào 1 file X
Bug: Nếu ô A1 là 000123, 0056sau khi copy lại nhảy thành 123, 56 mình muốn giữ cả 000123, 0056

Sub ImportData()
    Dim Master As Worksheet, Sh As Worksheet, wk As Workbook
    Dim strFolderPath As String, strFileName As String, Tenfile As String
    Dim v As Variant, Er As Long, Tmp1, Tmp2
    Dim Arr As Variant, sArr, dArr, I As Long, J As Long
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Set Master = ActiveWorkbook.Sheets("Sheet1")
Master.Range("A2:S" & Master.Range("A65535").End(3).Row + 1).Borders.LineStyle = xlNone
Master.Range("A2:S" & Master.Range("A65535").End(3).Row + 1).ClearContents
On Error GoTo Thoat
Arr = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
For v = LBound(Arr) To UBound(Arr)
    strFileName = Arr(v)
    Tmp1 = Split(strFileName, "\"): Tmp2 = Split(Tmp1(UBound(Tmp1)), "."): Tenfile = Tmp2(0)
    Set wk = Workbooks.Open(strFileName)
    For Each Sh In wk.Sheets
        If Sh.Name = "Sheet1" Then
            With Sh
                sArr = .Range("A2", .Range("A65535").End(3)).Resize(, 18).Value
                ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2) + 1)
                For I = 1 To UBound(sArr)
                    If sArr(I, 1) <> Empty Then
                        K = K + 1
                        For J = 1 To UBound(sArr, 2)
                            dArr(K, J) = sArr(I, J)
                        Next J
                        dArr(K, UBound(sArr, 2) + 1) = Tenfile
                    End If
                Next I
            End With
            With Master
                Er = .Range("A65535").End(3).Row
                If K Then
                    .Range("A" & Er + 1).Resize(K, UBound(sArr, 2) + 1) = dArr
                    .Range("A" & Er + 1).Resize(K, UBound(sArr, 2) + 1).Borders.LineStyle = xlContinuous
                    .Range("A" & Er + 1).Resize(K, UBound(sArr, 2) + 1).Borders(xlInsideHorizontal).Weight = xlHairline
                End If
            End With
        End If
        Exit For
    Next Sh
    wk.Close
    Erase dArr: K = 0
Next
MsgBox "Qua trinh lay du lieu hoan thanh   "
Thoat:
Exit Sub
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Cảm ơn mọi người

 

[881516]

hi anh chị em nào rảnh xem giúp mình nhé

 

[befaint]

Nếu ô A1 là 000123, 0056sau khi copy lại nhảy thành 123, 56 mình muốn giữ cả 000123, 0056

Cách:

For J = 1 To UBound(sArr, 2)
If J=1 then
dArr(K, J) = "'" & sArr(I, J)
Else
dArr(K, J) = sArr(I, J)
End If
Next J

Hoặc:

If K Then
                   .Range("A2:A65000").NumberFormat="@"
                   .Range("A" & Er + 1).Resize(K, UBound(sArr, 2) + 1) = dArr
                   .Range("A" & Er + 1).Resize(K, UBound(sArr, 2) + 1).Borders.LineStyle = xlContinuous
                   .Range("A" & Er + 1).Resize(K, UBound(sArr, 2) + 1).Borders(xlInsideHorizontal).Weight = xlHairline
End If

 

[881516]

Cách:

Thanks bạn
CÁch 1 ko hiểu sao mình làm nó vẫn bị như cũ,
Cách 2 thì ok rồi bạn, đơn giản hơn, thêm 1 dòng như của bạn là xong
Cảm ơn bạn nhiều nhé