Cần trợ giúp VBA

[bagiacom]

Mình có 3 file cần copy dữ liệu vào file tổng hợp. Bạn nào giúp mình với. Chân thành cảm ơn!

 

[quanluu]

Mình có 3 file cần copy dữ liệu vào file tổng hợp. Bạn nào giúp mình với. Chân thành cảm ơn!

Mình code theo mẫu

Sub TH()
Dim i As Integer, wbmain As Workbook, wb As Workbook
    Set wbmain = ThisWorkbook
    With wbmain
        For i = 1 To 3
           Set wb = Workbooks.Open(wbmain.Path & "\Ngay " & i & ".xlsx")
           wb.ActiveSheet.Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
           wb.Close False
        Next
    End With
End Sub

 

[bagiacom]

Mình code theo mẫu

Sub TH()
Dim i As Integer, wbmain As Workbook, wb As Workbook
    Set wbmain = ThisWorkbook
    With wbmain
        For i = 1 To 3
           Set wb = Workbooks.Open(wbmain.Path & "\Ngay " & i & ".xlsx")
           wb.ActiveSheet.Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
           wb.Close False
        Next
    End With
End Sub

Trước hết chân thành cảm ơn bác. Các file excel của mình tên khác nhau và trong mỗi file excel rất nhiều sheet. Mính sưu tầm được 1 đoạn code. Bạn có thể giúp mình sửa đoạn code này để áp dụng cho bài tập trên được không. Mình không mù tịt về VBA.
Option Explicit
Sub import_data()

Dim master As Worksheet, sh As Worksheet
Dim wk As Workbook
Dim strFolderPath As String
Dim selectedFiles As Variant
Dim iFileNum As Integer, iLastRowReport As Integer, iNumberOfRowsToPaste As Integer
Dim strFileName As String
Dim rID As Range, rQuantity As Range, rUnitPrice As Range, rKM As Range, rMC As Range
Dim iCurrentLastRow As Integer, iRowStartToPaste As Integer
Dim startTime As Double


getSpeed (True)
Set master = ActiveWorkbook.Sheets("Data")

strFolderPath = ActiveWorkbook.Path

ChDrive strFolderPath
ChDir strFolderPath

On Error GoTo NoFileSelected
selectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)

startTime = Timer
For iFileNum = LBound(selectedFiles) To UBound(selectedFiles)
strFileName = selectedFiles(iFileNum)

Set wk = Workbooks.Open(strFileName)
For Each sh In wk.Sheets
If sh.Name Like "*-REPORT" Then
With sh
iLastRowReport = .Range("A" & Rows.Count).End(xlUp).Row
iNumberOfRowsToPaste = iLastRowReport - 6 + 1

Set rID = .Range("A6:A" & iLastRowReport)
Set rQuantity = .Range("C6:C" & iLastRowReport)
Set rUnitPrice = .Range("F6:F" & iLastRowReport)
Set rKM = .Range("I6:I" & iLastRowReport)
Set rMC = .Range("K6:K" & iLastRowReport)

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

.Range("A" & iRowStartToPaste).Resize(iNumberOfRowsToPaste, 1) = rID.Value2
.Range("C" & iRowStartToPaste).Resize(iNumberOfRowsToPaste, 1) = rQuantity.Value2
.Range("E" & iRowStartToPaste).Resize(iNumberOfRowsToPaste, 1) = rUnitPrice.Value2
.Range("G" & iRowStartToPaste).Resize(iNumberOfRowsToPaste, 1) = rKM.Value2
.Range("I" & iRowStartToPaste).Resize(iNumberOfRowsToPaste, 1) = rMC.Value2
End With

End With
End If
Next sh
wk.Close
Next

MsgBox "Done in " & Int(Timer - startTime) & " s."
getSpeed (False)
NoFileSelected:
MsgBox "Chua co file nao duoc chon!"
End Sub

Function getSpeed(doIt As Boolean)
Application.ScreenUpdating = Not (doIt)
Application.EnableEvents = Not (doIt)
Application.Calculation = IIf(doIt, xlCalculationManual, xlCalculationAutomatic)
End Function

 

[bagiacom]

Mình code theo mẫu

Sub TH()
Dim i As Integer, wbmain As Workbook, wb As Workbook
    Set wbmain = ThisWorkbook
    With wbmain
        For i = 1 To 3
           Set wb = Workbooks.Open(wbmain.Path & "\Ngay " & i & ".xlsx")
           wb.ActiveSheet.Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
           wb.Close False
        Next
    End With
End Sub

Bạn sửa code giúp mình cho phù hợp với bản mẫu này được không. Chân thành cảm ơn!

 

[quanluu]

Bạn sửa code giúp mình cho phù hợp với bản mẫu này được không. Chân thành cảm ơn!

Bạn check code

Sub test()
Dim FSO As Object, FileItem As Object, i As Integer, wbmain As Workbook, wb As Workbook
Set wbmain = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With wbmain
    For Each FileItem In FSO.GetFolder(wbmain.Path).Files
        If FileItem.Name <> "Tong hop.xlsx" And Left(FileItem.Name, 1) <> "~" Then
            i = i + 1
            Set wb = Workbooks.Open(FileItem.Path)
            wb.Sheets("Tram 1").Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
            .ActiveSheet.Cells(2, i * 2) = Left(FileItem.Name, Len(FileItem.Name) - 5)
            wb.Close False
        End If
    Next
End With
End Sub

 

[bagiacom]

Bạn check code

Sub test()
Dim FSO As Object, FileItem As Object, i As Integer, wbmain As Workbook, wb As Workbook
Set wbmain = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With wbmain
    For Each FileItem In FSO.GetFolder(wbmain.Path).Files
        If FileItem.Name <> "Tong hop.xlsx" And Left(FileItem.Name, 1) <> "~" Then
            i = i + 1
            Set wb = Workbooks.Open(FileItem.Path)
            wb.Sheets("Tram 1").Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
            .ActiveSheet.Cells(2, i * 2) = Left(FileItem.Name, Len(FileItem.Name) - 5)
            wb.Close False
        End If
    Next
End With
End Sub

Chân thành cảm ơn bạn!

 

[bagiacom]

Bạn check code

Sub test()
Dim FSO As Object, FileItem As Object, i As Integer, wbmain As Workbook, wb As Workbook
Set wbmain = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With wbmain
    For Each FileItem In FSO.GetFolder(wbmain.Path).Files
        If FileItem.Name <> "Tong hop.xlsx" And Left(FileItem.Name, 1) <> "~" Then
            i = i + 1
            Set wb = Workbooks.Open(FileItem.Path)
            wb.Sheets("Tram 1").Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
            .ActiveSheet.Cells(2, i * 2) = Left(FileItem.Name, Len(FileItem.Name) - 5)
            wb.Close False
        End If
    Next
End With
End Sub

Cho mình hỏi thêm 1 chút. Hiện giờ dữ liệu được copy vào từ B4 đến G13, nhưng mình muốn chuyển sang copy vào vùng B4 đến C33 thì làm như thế nào?

 

[bagiacom]

Bạn check code

Sub test()
Dim FSO As Object, FileItem As Object, i As Integer, wbmain As Workbook, wb As Workbook
Set wbmain = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With wbmain
    For Each FileItem In FSO.GetFolder(wbmain.Path).Files
        If FileItem.Name <> "Tong hop.xlsx" And Left(FileItem.Name, 1) <> "~" Then
            i = i + 1
            Set wb = Workbooks.Open(FileItem.Path)
            wb.Sheets("Tram 1").Range("B3:C12").Copy .ActiveSheet.Cells(4, i * 2)
            .ActiveSheet.Cells(2, i * 2) = Left(FileItem.Name, Len(FileItem.Name) - 5)
            wb.Close False
        End If
    Next
End With
End Sub

Minh áp dụng cho file này không được, copy không đúng giá trị. Bạn xem giúp mình