Đồng bộ dữ liệu từ nhiều file vào 1 file

[hadoan-pap]

Em chào mọi người!

Em có chương trình tự động mở các file excel trong 1 folder, sau đó đồng bộ dữ lieu trên các file này vào 1 file khác.

Tuy nhiên trong đoạn code của em bên dưới thì đang chưa được như mong muốn của em, vì nó cứ đồng bộ 1 file sang là xóa bỏ toàn bộ dữ liệu cũ.

Em muốn nó đồng bộ dữ liệu sang, nhưng chỗ nào có dữ liệu ở cột L thì nó để im không làm gì ạ. Tức là nó chỉ đồng bộ dữ liệu mà không xóa cái hiện có dữ liệu ở cột L

Rất mong mọi người sửa giúp em ạ.

Em xin cảm ơn!

Dim arr, arr1
Dim k As Integer
Dim i, j As Long
Dim i1 As Integer


arr = ActiveWorkbook.Sheets("Sheet1").Range("B15:F" & ActiveWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr1 = Sheet2.Range("B3:R" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
ReDim arr2(1 To UBound(arr1, 1), 1 To 1)

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr, 1)

If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
arr2(i, 1) = UCase(arr(j, 5))
''arr3(i, 1) = UCase(arr(j, 8))
End If

Next j
Next i

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

 

[thuyyeu99]

Ban gán lần 2 thì L3 phải thay đổi chứ

 

[thnghiachau]

Em chào mọi người!

Em có chương trình tự động mở các file excel trong 1 folder, sau đó đồng bộ dữ lieu trên các file này vào 1 file khác.

Tuy nhiên trong đoạn code của em bên dưới thì đang chưa được như mong muốn của em, vì nó cứ đồng bộ 1 file sang là xóa bỏ toàn bộ dữ liệu cũ.

Em muốn nó đồng bộ dữ liệu sang, nhưng chỗ nào có dữ liệu ở cột L thì nó để im không làm gì ạ. Tức là nó chỉ đồng bộ dữ liệu mà không xóa cái hiện có dữ liệu ở cột L

Rất mong mọi người sửa giúp em ạ.

Em xin cảm ơn!

Dim arr, arr1
Dim k As Integer
Dim i, j As Long
Dim i1 As Integer


arr = ActiveWorkbook.Sheets("Sheet1").Range("B15:F" & ActiveWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr1 = Sheet2.Range("B3:R" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
ReDim arr2(1 To UBound(arr1, 1), 1 To 1)

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr, 1)

If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
arr2(i, 1) = UCase(arr(j, 5))
''arr3(i, 1) = UCase(arr(j, 8))
End If

Next j
Next i

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

Có được xem file hông nhỉ?

 

[befaint]

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

Const dong_dau = 3
Dim dong_cuoi as Long
dong_cuoi = Sheet2.Range("L" & rows.count).end(xlup).row
If dong_cuoi <= dong_dau Then dong_cuoi = 3 else dong_cuoi = doung_cuoi + 1
Sheet2.Range("L" & dong_cuoi).Resize(UBound(arr1, 1), 1).Value = arr2

 

[hadoan-pap]

Const dong_dau = 3
Dim dong_cuoi as Long
dong_cuoi = Sheet2.Range("L" & rows.count).end(xlup).row
If dong_cuoi <= dong_dau Then dong_cuoi = 3 else dong_cuoi = doung_cuoi + 1
Sheet2.Range("L" & dong_cuoi).Resize(UBound(arr1, 1), 1).Value = arr2

Em chào anh.

Em cảm ơn anh nhưng e them đoạn code của anh vào thì nó chạy k đúng lắm ạ.

Em xin lỗi vì không đưa được file lên vì nó nặng. Toàn bộ đoạn code của em như bên dưới ạ... Nếu sửa thì phải sửa thế nào mong anh góp y .

Em xin cảm ơn!

Dim MyFile As String
MyPath = "C:\Users\Administrator\1\"
MyFile = Dir(MyPath)
Do While MyFile <> ""
If MyFile Like "*.xlsm" Then
Workbooks.Open MyPath & MyFile

Dim arr, arr1
Dim k As Integer
Dim i, j As Long
Dim i1 As Integer


arr = ActiveWorkbook.Sheets("Sheet1").Range("B15:F" & ActiveWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr1 = Sheet2.Range("B3:R" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
ReDim arr2(1 To UBound(arr1, 1), 1 To 1)

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr, 1)

If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
arr2(i, 1) = UCase(arr(j, 5))
''arr3(i, 1) = UCase(arr(j, 8))
End If

Next j
Next i

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

ActiveWorkbook.Close True
End If
MyFile = Dir
Loop

 

[Gà Công Nghệ]

Em chào anh.

Em cảm ơn anh nhưng e them đoạn code của anh vào thì nó chạy k đúng lắm ạ.

Em xin lỗi vì không đưa được file lên vì nó nặng. Toàn bộ đoạn code của em như bên dưới ạ... Nếu sửa thì phải sửa thế nào mong anh góp y .

Em xin cảm ơn!

Dim MyFile As String
MyPath = "C:\Users\Administrator\1\"
MyFile = Dir(MyPath)
Do While MyFile <> ""
If MyFile Like "*.xlsm" Then
Workbooks.Open MyPath & MyFile

Dim arr, arr1
Dim k As Integer
Dim i, j As Long
Dim i1 As Integer


arr = ActiveWorkbook.Sheets("Sheet1").Range("B15:F" & ActiveWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr1 = Sheet2.Range("B3:R" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
ReDim arr2(1 To UBound(arr1, 1), 1 To 1)

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr, 1)

If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
arr2(i, 1) = UCase(arr(j, 5))
''arr3(i, 1) = UCase(arr(j, 8))
End If

Next j
Next i

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

ActiveWorkbook.Close True
End If
MyFile = Dir
Loop

Thích xem file hơn. File nặng đưa lên drive của gmail rồi chia sẻ clink được mà bạn. Thân!

 

[HieuCD]

Em chào mọi người!

Em có chương trình tự động mở các file excel trong 1 folder, sau đó đồng bộ dữ lieu trên các file này vào 1 file khác.

Tuy nhiên trong đoạn code của em bên dưới thì đang chưa được như mong muốn của em, vì nó cứ đồng bộ 1 file sang là xóa bỏ toàn bộ dữ liệu cũ.

Em muốn nó đồng bộ dữ liệu sang, nhưng chỗ nào có dữ liệu ở cột L thì nó để im không làm gì ạ. Tức là nó chỉ đồng bộ dữ liệu mà không xóa cái hiện có dữ liệu ở cột L

Rất mong mọi người sửa giúp em ạ.

Em xin cảm ơn!

Dim arr, arr1
Dim k As Integer
Dim i, j As Long
Dim i1 As Integer
arr = ActiveWorkbook.Sheets("Sheet1").Range("B15:F" & ActiveWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Value  'lây giá tri vao mang
arr1 = Sheet2.Range("B3:R" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr2 = Sheet2.Range("L3:L" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value

For i = 1 To UBound(arr1, 1)
if arr2(i, 1)=empty then
For j = 1 To UBound(arr, 1)
    If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
       arr2(i, 1) = UCase(arr(j, 5))
    End If
Next j
End If
Next i

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

 

[befaint]

them

Gửi cái đã thêm lên đây.

 

[hadoan-pap]

Dim arr, arr1
Dim k As Integer
Dim i, j As Long
Dim i1 As Integer
arr = ActiveWorkbook.Sheets("Sheet1").Range("B15:F" & ActiveWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Value  'lây giá tri vao mang
arr1 = Sheet2.Range("B3:R" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr2 = Sheet2.Range("L3:L" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Value

For i = 1 To UBound(arr1, 1)
if arr2(i, 1)=empty then
For j = 1 To UBound(arr, 1)
    If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
       arr2(i, 1) = UCase(arr(j, 5))
    End If
Next j
End If
Next i

Sheet2.Range("L3").Resize(UBound(arr1, 1), 1).Value = arr2

Em cảm ơn anh nhiều ạ

Cảm ơn mọi người rất nhiều.

 

[Cá ngừ F1]

Thông tin của bạn đưa lên lờ mờ, mọi người trả lời cũng lờ mờ, trúng thì trúng không trúng thì trượt.
Tốt nhất là phải có File