4. Truy cap bang tinh P1
Sub tai_sao_khong_nen_dung_msgbox_de_kiem_tra_loi()
For i = 1 To 10
Debug.Print "Xin Chao -- " & i
Next i
End Sub
Sub truy_cap_workbook()
' Tim ten workbook hien thoi
Debug.Print ActiveWorkbook.Name
' Tim duong dan den workbook hien thoi
Debug.Print ActiveWorkbook.Path
' Tim duong dan va ten cua workbook hien thoi
Debug.Print ActiveWorkbook.FullName
End Sub
Sub truy_cap_worksheet()
' Truy cap vao bang tinh hien thoi
Debug.Print ActiveWorkbook.ActiveSheet.Name
' Truy cap vao bang tinh dua tren so thu tu
Debug.Print ActiveWorkbook.Worksheets(3).Name
' Truy cap vao bang tinh dua tren ten cua bang tinh
ActiveWorkbook.Worksheets("Vi du").Activate
End Sub
Sub truy_cap_Range()
' Truy cap vao o A1
' Range("A1").Select
' Truy cap vao mang A1:B5
' Range("A1:B5").Select
' Truy cap vao mang A1:B5 va A13:A15
' Range("A1:B5,A13:A15").Select
' Truy cap vao cot A
' Range ("A:A").select
' Columns("B").Value = ""
' Truy cap vao hang thu 1
' Range ("1:1").select
' Rows(1).Select
' Truy cap vao cot A den C
' Range ("A:C").select
' Truy cap vao hang 1 den 5
' Range ("1:5").select
' Truy cap vao hang 1,3,8
' Range ("1:1,3:3,8:8").select
' Truy cap vao cot A, C va F
' Range ("A:A,C:C,F:F").select
End Sub
Sub truy_cap_cell()
' ############### Cells(ha`ng, co^.t)
' Truy cap toan bo o cua bang tinh
' Cells.Select
' Truy cap 1 o cua bang tinh dua tren vi tri cua o
' Cells(7, 1).Select
' Truy cap 1 o cua bang tinh dua tren vi tri hang va ten cot
End Sub
Sub dien_du_lieu()
Range("B3").Value = ActiveWorkbook.Name
Cells(4, 2).Value = ActiveWorkbook.Path
Cells(5, 2).Value = ActiveWorkbook.FullName
Cells(7, 2) = ActiveWorkbook.ActiveSheet.Name
Cells(3, "B").Font.Size = 20
End Sub
----------------------------------------------------------------
5. Truy cap bang tinh P2
Sub tai_sao_khong_nen_dung_msgbox_de_kiem_tra_loi()
For i = 1 To 10
Debug.Print "Xin Chao -- " & i
Next i
End Sub
Sub truy_cap_workbook()
' Tim ten workbook hien thoi
Debug.Print ActiveWorkbook.Name
' Tim duong dan den workbook hien thoi
Debug.Print ActiveWorkbook.Path
' Tim duong dan va ten cua workbook hien thoi
Debug.Print ActiveWorkbook.FullName
End Sub
Sub truy_cap_worksheet()
' Truy cap vao bang tinh hien thoi
Debug.Print ActiveWorkbook.ActiveSheet.Name
' Truy cap vao bang tinh dua tren so thu tu
Debug.Print ActiveWorkbook.Worksheets(3).Name
' Truy cap vao bang tinh dua tren ten cua bang tinh
ActiveWorkbook.Worksheets("Vi du").Activate
End Sub
Sub truy_cap_Range()
' Truy cap vao o A1
' Range("A1").Select
' Truy cap vao mang A1:B5
' Range("A1:B5").Select
' Truy cap vao mang A1:B5 va A13:A15
' Range("A1:B5,A13:A15").Select
' Truy cap vao cot A
' Range ("A:A").select
' Columns("B").Value = ""
' Truy cap vao hang thu 1
' Range ("1:1").select
' Rows(1).Select
' Truy cap vao cot A den C
' Range ("A:C").select
' Truy cap vao hang 1 den 5
' Range ("1:5").select
' Truy cap vao hang 1,3,8
' Range ("1:1,3:3,8:8").select
' Truy cap vao cot A, C va F
' Range ("A:A,C:C,F:F").select
End Sub
Sub truy_cap_cell()
' ############### Cells(ha`ng, co^.t)
' Truy cap toan bo o cua bang tinh
' Cells.Select
' Truy cap 1 o cua bang tinh dua tren vi tri cua o
' Cells(7, 1).Select
' Truy cap 1 o cua bang tinh dua tren vi tri hang va ten cot
End Sub
Sub dien_du_lieu()
Range("B3").Value = ActiveWorkbook.Name
Cells(4, 2).Value = ActiveWorkbook.Path
Cells(5, 2).Value = ActiveWorkbook.FullName
Cells(7, 2) = ActiveWorkbook.ActiveSheet.Name
Cells(3, "B").Font.Size = 20
End Sub
-------------------------------------------------------------------------------
6. sub và functio
Sub main()
' Khai bao bien chieu_rong, chieu_dai o dang Double
Dim chieu_rong As Double
Dim chieu_dai As Double
'dim chieu_rong#
' Goi hop thoai yeu cau nguoi dung nhap thong tin
chieu_rong = InputBox(Prompt:="Xin nhap chieu rong")
chieu_dai = InputBox(Prompt:="Xin nhap chieu dai")
' Hien ket qua bang MsgBox
MsgBox tinh_dien_tich(chieu_dai, chieu_rong)
End Sub
' viet function tinh dien tich hinh chu nhat
' dua tren chieu dai va chieu rong
Function tinh_dien_tich(chieu_dai As Double, chieu_rong As Double)
tinh_dien_tich = chieu_dai * chieu_rong
End Function
------------------------------------------------------------------------------------
9. contination formating
Sub Macro2()
'
' Macro2 Macro
'
'
Range("I5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End Sub
------------------------------------------------------
10. Tao bao cao PPT
Sub tao_bao_cao_excel()
Dim header As Variant
Dim data As Variant
Dim numberOfSalesman As Integer
Dim i As Integer
Dim ws As Worksheet
Dim worksheetName As String
header = ThisWorkbook.Sheets("Data").Range("A1:F1").Value
numberOfSalesman = ThisWorkbook.Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row - 1
data = ThisWorkbook.Sheets("Data").Range("A2:F" & (numberOfSalesman + 1))
For i = LBound(data, 1) To UBound(data, 1)
worksheetName = "NhanVien" & data(i, 1)
Set ws = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = worksheetName
With ThisWorkbook.Sheets(worksheetName)
.Range("A1:F1").Value = header
.Range("A2") = data(i, 1)
.Range("B2") = data(i, 2)
.Range("C2") = data(i, 3) * ThisWorkbook.Names("don_gia_cam").RefersToRange.Value
.Range("D2") = data(i, 4) * ThisWorkbook.Names("don_gia_quyt").RefersToRange.Value
.Range("E2") = data(i, 5) * ThisWorkbook.Names("don_gia_mit").RefersToRange.Value
.Range("F2") = data(i, 6) * ThisWorkbook.Names("don_gia_dua").RefersToRange.Value
.Range("G1") = ThisWorkbook.Names("vntext_tong_so").RefersToRange.Value
.Range("G2").Formula = "=SUM(C2:F2)"
.Range("G2").NumberFormat = "[$VND] #,##0.00"
.Range("C3:F3").Formula = "=C2/$G$2"
.Range("C3:F3").NumberFormat = "0.00%"
.Range("H2").Formula = "=VLOOKUP(G2,xep_loai,2,TRUE)"
With .ChartObjects.Add _
(Left:=100, Width:=375, Top:=75, Height:=225)
.Chart.SetSourceData Source:=Sheets(worksheetName).Range("C1:F1,C3:F3")
.Chart.ChartType = xlPie
.Chart.SetElement (msoElementDataLabelBestFit)
End With
End With
Next
End Sub
Sub tao_ppt()
Dim pptTemplate As PowerPoint.Presentation
Dim slideobj As Object, sh As Object
Dim rng As Range
Dim templatePath As String
Const cmToPoint = 28.3464567
Dim chartInSlide As Object
templatePath = ActiveWorkbook.Path & "\template.pptx"
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Open(templatePath)
Set pptTemplate = pptPres
For Each sh In ThisWorkbook.Sheets
If sh.Name Like "NhanVien*" Then
Set slideobj = pptTemplate.Slides.Add(pptTemplate.Slides.Count, ppLayoutBlank)
slideobj.Select
With sh
Set ten_nhan_vien = slideobj.Shapes.AddShape(msoShapeRectangle, _
0.7 * cmToPoint, _
2.7 * cmToPoint, _
15 * cmToPoint, _
1.6 * cmToPoint)
With ten_nhan_vien
.TextFrame.TextRange.ParagraphFormat.Bullet.Visible = False
.TextFrame.TextRange.Text = sh.Range("B2")
.TextFrame.TextRange.Font.Size = 18
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Font.Name = "Arial"
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = RGB(0, 0, 0)
End With
Set xep_loai = slideobj.Shapes.AddShape(msoShapeRectangle, _
17.5 * cmToPoint, _
2.7 * cmToPoint, _
6 * cmToPoint, _
1.6 * cmToPoint)
With xep_loai
.TextFrame.TextRange.ParagraphFormat.Bullet.Visible = False
.TextFrame.TextRange.Text = ThisWorkbook.Names("vntext_xep_loai").RefersToRange.Value & " " & sh.Range("H2")
.TextFrame.TextRange.Font.Size = 18
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Font.Name = "Arial"
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = RGB(0, 0, 0)
End With
.Activate
.ChartObjects(1).Select
ActiveChart.ChartArea.Copy
pptApp.ActiveWindow.View.Paste
Set chartInSlide = slideobj.Shapes(slideobj.Shapes.Count)
With chartInSlide
.Left = 0.7 * cmToPoint
.Top = 4.92 * cmToPoint
.Height = 11.4 * cmToPoint
.Width = 22.78 * cmToPoint
End With
End With
End If
Next
End Sub
-----------------------------------------------------------------
11. Tong ket du lieu nhieu file vao 1 file
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
--------------------------------------------------------------------------------------------
16. Loc tach du lieu
Sub loc_du_lieu()
Dim ws As Worksheet
Dim my_arr As Variant
Dim filter_column As Integer: filter_column = 2
Dim d As Object
Dim lr As Long, i As Integer
Dim Header As String
Dim v As Variant
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set ws = Sheets("SalesOrders")
lr = ws.Cells(ws.Rows.Count, filter_column).End(xlUp).Row
Header = "A1:G1"
my_arr = Application.WorksheetFunction.Transpose(ws.Range(Cells(2, filter_column), Cells(lr, filter_column)))
For i = LBound(my_arr) To UBound(my_arr)
d(my_arr(i)) = 1
Next i
For Each v In d.keys()
ws.Range(Header).AutoFilter field:=filter_column, Criteria1:=v
If Not Evaluate("=ISREF('" & v & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = v
Else
Sheets(v).Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A1:A" & lr).EntireRow.Copy Sheets(v).Range("A1")
Sheets(v).Columns.AutoFit
Next v
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Sub tai_sao_khong_nen_dung_msgbox_de_kiem_tra_loi()
For i = 1 To 10
Debug.Print "Xin Chao -- " & i
Next i
End Sub
Sub truy_cap_workbook()
' Tim ten workbook hien thoi
Debug.Print ActiveWorkbook.Name
' Tim duong dan den workbook hien thoi
Debug.Print ActiveWorkbook.Path
' Tim duong dan va ten cua workbook hien thoi
Debug.Print ActiveWorkbook.FullName
End Sub
Sub truy_cap_worksheet()
' Truy cap vao bang tinh hien thoi
Debug.Print ActiveWorkbook.ActiveSheet.Name
' Truy cap vao bang tinh dua tren so thu tu
Debug.Print ActiveWorkbook.Worksheets(3).Name
' Truy cap vao bang tinh dua tren ten cua bang tinh
ActiveWorkbook.Worksheets("Vi du").Activate
End Sub
Sub truy_cap_Range()
' Truy cap vao o A1
' Range("A1").Select
' Truy cap vao mang A1:B5
' Range("A1:B5").Select
' Truy cap vao mang A1:B5 va A13:A15
' Range("A1:B5,A13:A15").Select
' Truy cap vao cot A
' Range ("A:A").select
' Columns("B").Value = ""
' Truy cap vao hang thu 1
' Range ("1:1").select
' Rows(1).Select
' Truy cap vao cot A den C
' Range ("A:C").select
' Truy cap vao hang 1 den 5
' Range ("1:5").select
' Truy cap vao hang 1,3,8
' Range ("1:1,3:3,8:8").select
' Truy cap vao cot A, C va F
' Range ("A:A,C:C,F:F").select
End Sub
Sub truy_cap_cell()
' ############### Cells(ha`ng, co^.t)
' Truy cap toan bo o cua bang tinh
' Cells.Select
' Truy cap 1 o cua bang tinh dua tren vi tri cua o
' Cells(7, 1).Select
' Truy cap 1 o cua bang tinh dua tren vi tri hang va ten cot
End Sub
Sub dien_du_lieu()
Range("B3").Value = ActiveWorkbook.Name
Cells(4, 2).Value = ActiveWorkbook.Path
Cells(5, 2).Value = ActiveWorkbook.FullName
Cells(7, 2) = ActiveWorkbook.ActiveSheet.Name
Cells(3, "B").Font.Size = 20
End Sub
----------------------------------------------------------------
5. Truy cap bang tinh P2
Sub tai_sao_khong_nen_dung_msgbox_de_kiem_tra_loi()
For i = 1 To 10
Debug.Print "Xin Chao -- " & i
Next i
End Sub
Sub truy_cap_workbook()
' Tim ten workbook hien thoi
Debug.Print ActiveWorkbook.Name
' Tim duong dan den workbook hien thoi
Debug.Print ActiveWorkbook.Path
' Tim duong dan va ten cua workbook hien thoi
Debug.Print ActiveWorkbook.FullName
End Sub
Sub truy_cap_worksheet()
' Truy cap vao bang tinh hien thoi
Debug.Print ActiveWorkbook.ActiveSheet.Name
' Truy cap vao bang tinh dua tren so thu tu
Debug.Print ActiveWorkbook.Worksheets(3).Name
' Truy cap vao bang tinh dua tren ten cua bang tinh
ActiveWorkbook.Worksheets("Vi du").Activate
End Sub
Sub truy_cap_Range()
' Truy cap vao o A1
' Range("A1").Select
' Truy cap vao mang A1:B5
' Range("A1:B5").Select
' Truy cap vao mang A1:B5 va A13:A15
' Range("A1:B5,A13:A15").Select
' Truy cap vao cot A
' Range ("A:A").select
' Columns("B").Value = ""
' Truy cap vao hang thu 1
' Range ("1:1").select
' Rows(1).Select
' Truy cap vao cot A den C
' Range ("A:C").select
' Truy cap vao hang 1 den 5
' Range ("1:5").select
' Truy cap vao hang 1,3,8
' Range ("1:1,3:3,8:8").select
' Truy cap vao cot A, C va F
' Range ("A:A,C:C,F:F").select
End Sub
Sub truy_cap_cell()
' ############### Cells(ha`ng, co^.t)
' Truy cap toan bo o cua bang tinh
' Cells.Select
' Truy cap 1 o cua bang tinh dua tren vi tri cua o
' Cells(7, 1).Select
' Truy cap 1 o cua bang tinh dua tren vi tri hang va ten cot
End Sub
Sub dien_du_lieu()
Range("B3").Value = ActiveWorkbook.Name
Cells(4, 2).Value = ActiveWorkbook.Path
Cells(5, 2).Value = ActiveWorkbook.FullName
Cells(7, 2) = ActiveWorkbook.ActiveSheet.Name
Cells(3, "B").Font.Size = 20
End Sub
-------------------------------------------------------------------------------
6. sub và functio
Sub main()
' Khai bao bien chieu_rong, chieu_dai o dang Double
Dim chieu_rong As Double
Dim chieu_dai As Double
'dim chieu_rong#
' Goi hop thoai yeu cau nguoi dung nhap thong tin
chieu_rong = InputBox(Prompt:="Xin nhap chieu rong")
chieu_dai = InputBox(Prompt:="Xin nhap chieu dai")
' Hien ket qua bang MsgBox
MsgBox tinh_dien_tich(chieu_dai, chieu_rong)
End Sub
' viet function tinh dien tich hinh chu nhat
' dua tren chieu dai va chieu rong
Function tinh_dien_tich(chieu_dai As Double, chieu_rong As Double)
tinh_dien_tich = chieu_dai * chieu_rong
End Function
------------------------------------------------------------------------------------
9. contination formating
Sub Macro2()
'
' Macro2 Macro
'
'
Range("I5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End Sub
------------------------------------------------------
10. Tao bao cao PPT
Sub tao_bao_cao_excel()
Dim header As Variant
Dim data As Variant
Dim numberOfSalesman As Integer
Dim i As Integer
Dim ws As Worksheet
Dim worksheetName As String
header = ThisWorkbook.Sheets("Data").Range("A1:F1").Value
numberOfSalesman = ThisWorkbook.Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row - 1
data = ThisWorkbook.Sheets("Data").Range("A2:F" & (numberOfSalesman + 1))
For i = LBound(data, 1) To UBound(data, 1)
worksheetName = "NhanVien" & data(i, 1)
Set ws = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = worksheetName
With ThisWorkbook.Sheets(worksheetName)
.Range("A1:F1").Value = header
.Range("A2") = data(i, 1)
.Range("B2") = data(i, 2)
.Range("C2") = data(i, 3) * ThisWorkbook.Names("don_gia_cam").RefersToRange.Value
.Range("D2") = data(i, 4) * ThisWorkbook.Names("don_gia_quyt").RefersToRange.Value
.Range("E2") = data(i, 5) * ThisWorkbook.Names("don_gia_mit").RefersToRange.Value
.Range("F2") = data(i, 6) * ThisWorkbook.Names("don_gia_dua").RefersToRange.Value
.Range("G1") = ThisWorkbook.Names("vntext_tong_so").RefersToRange.Value
.Range("G2").Formula = "=SUM(C2:F2)"
.Range("G2").NumberFormat = "[$VND] #,##0.00"
.Range("C3:F3").Formula = "=C2/$G$2"
.Range("C3:F3").NumberFormat = "0.00%"
.Range("H2").Formula = "=VLOOKUP(G2,xep_loai,2,TRUE)"
With .ChartObjects.Add _
(Left:=100, Width:=375, Top:=75, Height:=225)
.Chart.SetSourceData Source:=Sheets(worksheetName).Range("C1:F1,C3:F3")
.Chart.ChartType = xlPie
.Chart.SetElement (msoElementDataLabelBestFit)
End With
End With
Next
End Sub
Sub tao_ppt()
Dim pptTemplate As PowerPoint.Presentation
Dim slideobj As Object, sh As Object
Dim rng As Range
Dim templatePath As String
Const cmToPoint = 28.3464567
Dim chartInSlide As Object
templatePath = ActiveWorkbook.Path & "\template.pptx"
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Open(templatePath)
Set pptTemplate = pptPres
For Each sh In ThisWorkbook.Sheets
If sh.Name Like "NhanVien*" Then
Set slideobj = pptTemplate.Slides.Add(pptTemplate.Slides.Count, ppLayoutBlank)
slideobj.Select
With sh
Set ten_nhan_vien = slideobj.Shapes.AddShape(msoShapeRectangle, _
0.7 * cmToPoint, _
2.7 * cmToPoint, _
15 * cmToPoint, _
1.6 * cmToPoint)
With ten_nhan_vien
.TextFrame.TextRange.ParagraphFormat.Bullet.Visible = False
.TextFrame.TextRange.Text = sh.Range("B2")
.TextFrame.TextRange.Font.Size = 18
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Font.Name = "Arial"
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = RGB(0, 0, 0)
End With
Set xep_loai = slideobj.Shapes.AddShape(msoShapeRectangle, _
17.5 * cmToPoint, _
2.7 * cmToPoint, _
6 * cmToPoint, _
1.6 * cmToPoint)
With xep_loai
.TextFrame.TextRange.ParagraphFormat.Bullet.Visible = False
.TextFrame.TextRange.Text = ThisWorkbook.Names("vntext_xep_loai").RefersToRange.Value & " " & sh.Range("H2")
.TextFrame.TextRange.Font.Size = 18
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Font.Name = "Arial"
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = RGB(0, 0, 0)
End With
.Activate
.ChartObjects(1).Select
ActiveChart.ChartArea.Copy
pptApp.ActiveWindow.View.Paste
Set chartInSlide = slideobj.Shapes(slideobj.Shapes.Count)
With chartInSlide
.Left = 0.7 * cmToPoint
.Top = 4.92 * cmToPoint
.Height = 11.4 * cmToPoint
.Width = 22.78 * cmToPoint
End With
End With
End If
Next
End Sub
-----------------------------------------------------------------
11. Tong ket du lieu nhieu file vao 1 file
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
--------------------------------------------------------------------------------------------
16. Loc tach du lieu
Sub loc_du_lieu()
Dim ws As Worksheet
Dim my_arr As Variant
Dim filter_column As Integer: filter_column = 2
Dim d As Object
Dim lr As Long, i As Integer
Dim Header As String
Dim v As Variant
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set ws = Sheets("SalesOrders")
lr = ws.Cells(ws.Rows.Count, filter_column).End(xlUp).Row
Header = "A1:G1"
my_arr = Application.WorksheetFunction.Transpose(ws.Range(Cells(2, filter_column), Cells(lr, filter_column)))
For i = LBound(my_arr) To UBound(my_arr)
d(my_arr(i)) = 1
Next i
For Each v In d.keys()
ws.Range(Header).AutoFilter field:=filter_column, Criteria1:=v
If Not Evaluate("=ISREF('" & v & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = v
Else
Sheets(v).Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A1:A" & lr).EntireRow.Copy Sheets(v).Range("A1")
Sheets(v).Columns.AutoFit
Next v
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
