Tính tổng với sumproduct B3=SUMPRODUCT(SUMIFS(Data!$C:$C,Data!$A:$A,A3,Data!$B:$B,'DS VIP'!$A$2:$A$5))
Đếm tổng với countif C3=SUMPRODUCT(COUNTIFS(Data!A:A,A3,Data!B:B,'DS VIP'!$A$2:$A$5))
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
' Mo va chon file can copy
selectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
' Neu loi thi bo qua va tiep tuc
On Error Resume Next
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
getSpeed (False)
End Sub
Function getSpeed(doIt As Boolean)
Application.ScreenUpdating = Not (doIt)
Application.EnableEvents = Not (doIt)
Application.Calculation = IIf(doIt, xlCalculationManual, xlCalculationAutomatic)
End Function
Sub laythongtin()
Dim i As Long
Dim LastRow As Long
Dim Luu As String
' tim hang cuoi cung cua cot A trong sheet1
LastRow = Worksheets(Sheet1.Name).Cells(2, "A").End(xlDown).Row
For i = 2 To LastRow
If Cells(i, "A") <> "" Then
Luu = Luu & "," & Cells(i, "B").Value
End If
Next i
Cells(3, "C").Value = Luu
End Sub
Sub Range_End_Method()
'Finds the last non-blank cell in a single row or column
Dim DongCuoi As Long
Dim CotCuoi As Long
'Find the last non-blank cell in column A(1)
DongCuoi = Cells(Rows.Count, 1).End(xlUp).Row
'Find the last non-blank cell in row 1
CotCuoi = Cells(1, Columns.Count).End(xlToLeft).Column
MsgBox "Last Row: " & lRow & vbNewLine & _
"Last Column: " & lCol
End Sub
Sub LocDuLieu_Duynhat()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
Dim LastRow As Long
LastRow = Worksheets(Sheet1.Name).Cells(2, "A").End(xlDown).Row
'Lay du lieu can loc dua vao mang
vaData = Sheet1.Range("A2:G" & LastRow).Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheet1.Range("B2").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Sub copy_paste_special()
'Sử dụng phương thức Range.PasteSpecial để dán dữ liệu copy
'Copy và PasteSpecial trongrange
Range("A1").Copy
Range("A3").PasteSpecial Paste:=xlPasteFormats
'Copy và PasteSpecial giữa các worksheets
Worksheets("Sheet1").Range("A2").Copy
Worksheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteFormulas
'Copy và PasteSpecial giữa các workbooks
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteFormats
'Xóa đường viền copy xung quanh khu vực chọn copy
Application.CutCopyMode = False
End Sub
Sub copy_paste_simple()
'Sử dụng phương thức Range.Copy cho copy/paste
'Phương thức Range.Copy để Copy & Paste trên một dòng
Range("A1").Copy Range("C1")
Range("A1:A3").Copy Range("D1:D3")
Range("A1:A3").Copy Range("D1")
'Range.Copy trên các worksheets khác nhau
Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("A1")
'Range.Copy trên các workbooks khác nhau
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy _
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
Sub Paste_Values_Examples()
'Set the cells' values equal to another to paste values
'Set a cell's value equal to another cell's value
Range("C1").Value = Range("A1").Value
Range("D1:D3").Value = Range("A1:A3").Value
'Set values between worksheets
Worksheets("Sheet2").Range("A1").Value = Worksheets("Sheet1").Range("A1").Value
'Set values between workbooks
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value
End Sub
Sub Dienthoai()
Dim i As Integer
Dim LastRow1 As Long
LastRow1 = Worksheets("Free 50k").Cells(4, "B").End(xlDown).Row
Application.Interactive = False
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = 4 To LastRow1
'Cells(i, 11).Value = "=INDEX(Data!B:F,MATCH(B4,Data!B:B,0),5)"
Cells(i, 11).Value = Application.Index(Worksheets("data").Range("B:F"), Application.Match(Range("B" & i), Worksheets("data").Range("B:B"), 0), 5)
Next i
Application.Interactive = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub Select_File_Or_Files_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' You can also use a fixed path.
'MyPath = "C:\Users\Ron de Bruin\Test"
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Excel Files (*.xls), *.xlsx", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You opened this file : " & Fname(N) & vbNewLine & _
"And after you press OK, it will be closed" & vbNewLine & _
"without saving. You can replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Fname = Application.GetOpenFilename( _
FileFilter:="XLS Files (*.xls),*.xls,CSV Files (*.csv),*.csv", _
Title:="Select a file or files", _
MultiSelect:=True)
Sub Macro1()
Dim i As Integer, j As Integer, a As Integer, b As Integer, kq As Integer
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim Macro1 As Integer
Dim Total As Integer
LastRow1 = Worksheets("Data").Cells(2, "H").End(xlDown).Row
LastRow2 = Worksheets("Data").Cells(2, "I").End(xlDown).Row
' Tìm vị trí của hàng có chữ Macro1
Macro1 = Application.Match("Macro1", Worksheets("sheet2").Range("A:A"), 0)
' Tìm vị trí của hàng có chữ Total
Total = Application.Match("TOTAL", Worksheets("sheet2").Range("A:A"), 0)
Application.Interactive = False
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = Macro1 + 1 To Total - 1 ' Chạy vòng lặp từ vị trí đứng dưới chữ Macro đến vị trí đứng trên chữ total
a = 0
b = 0
kq = 0
For j = 4 To 29
a = Application.CountIfs(Worksheets("Data").Range("H2:H" & LastRow1), Worksheets("sheet2").Range("B" & i), Worksheets("Data").Range("I2:I" & LastRow2), Worksheets("sheet2").Cells(1, j))
b = Application.CountIfs(Worksheets("Data").Range("H2:H" & LastRow1), Worksheets("sheet2").Range("C" & i), Worksheets("Data").Range("I2:I" & LastRow2), Worksheets("sheet2").Cells(1, j))
kq = a + b
Cells(i, j).Value = kq
Next j
Next i
Application.Interactive = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
