Cám ơn Anh nhiều
Bạn xem lại 2 chỗ ghi chú trong code:
Private Sub CommandButton1_Click()
Dim Dic As Object, sArr(), dArr(), I As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([C8], [C8].End(xlDown)).Resize(, 6).Value2
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1) & sArr(I, 3) '<-------Chỗ này---------'
If Not Dic.Exists(Tem) Then
Dic.Add Tem, sArr(I, 6)
Else
Dic.Item(Tem) = Dic.Item(Tem) + sArr(I, 6)
End If
Next I
For I = 1 To UBound(sArr, 1)
dArr(I, 1) = Dic.Item(sArr(I, 1) & sArr(I, 3)) '<------và chỗ này-------------'
Next I
[I8].Resize(I - 1) = dArr
Set Dic = Nothing
End SubEm đã giải quyết được vấn đề của mình. Lỗi ở 1 dòng code khiến nó không hoạt động được như ý.
Sub XoaSoLieu()
Sheets("HD").Select
Range("B11:B14", "F3", "A3", "B19", "E29", "C31").Select
Selection.ClearContents
Range("F1").Select
End Sub
Trong ổ D, tạo 1 Folder mới với tên là DIEN_2018.
Sub ThuXuatFile_Moi()
Dim Path As String
Dim filename As String
Dim FileMoi
Path = "D:\DIEN_2018\"
filename = Sheet1.Range("K4") 'gõ tên File càn luu vào K4
Set FileMoi = Workbooks.Add
Sheet1.Copy Before:=FileMoi.Sheets(1)
ActiveWorkbook.SaveAs filename:=Path & filename & ".xls", FileFormat:=xlNormal
ActiveWindow.Close
End Subem cần 2 file đặt chung 1 folder, và không cố định đường dẫn (như bác đang là D:\Dien2018...) để có thể linh hoạt hơn trong sử dụng (share cho người khác, đặt trong folder dự án khác nhau...)
Tại K4 của sheet Data_Cable bạn gõ tên File cần lưu, khi lưu thì nó hiện hộp thoại bạn muốn lưu chỗ nào là tùy bạn.
Sub Luu_TuyChon()
Dim TenFile As String
Dim FileMoi As Object
TenFile = Sheet1.Range("K4")
Set FileMoi = Workbooks.Add
Sheet1.Copy Before:=FileMoi.Sheets(1)
Application.Dialogs(xlDialogSaveAs).Show TenFile
ActiveWindow.Close
End SubThisWorkbook.Worksheets("Data_Cable")Trong code trên:
'ThisWorkbook.Sheets("Data_Cable").Copy Before:=FileMoi.Sheets(1)
Sheet1.Copy Before:=FileMoi.Sheets(1)
Vấn đề không đơn giản như đã trình bầy ở chủ đề này - vài dòng code tách sheet sang tập tin mới..
Bác nhắc em mới để ý đến, để em sửa lại phần Name. Nếu phương án sửa tham chiếu về tập tin đóng chạy được thì em sẽ chuyển phần Name (phục vụ cho Data Validation) về chung file bảng tính chọn, file Data chỉ để thông số của dây cáp. Em cũng muốn bảng tính nó hoàn thiện dần, tốt hơn. Em cũng không kinh nghiệm nhiều về code (thời sinh viên em cũng mày mò 1 ít Matlab) nên mong các bác chỉ bảo thêm.
Tôi thấy bạn đưa cái File này: Ladder size Calculation v1, khác với sheet gốc mà không diễn giải nên chẳng hiểu gì ráo.
Sub Send_Files()
'Working in 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send
'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Private Sub Test_Mau()
Dim Arr(), i As Long, x1, x2
Dim Qry As String
Arr = Range("A4:B100").Value
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) <> "" Then
x1 = GetValue(Arr(i, 1))
x2 = GetValue(Arr(i, 2))
MsgBox x1
Qry = "INSERT INTO Manh2 VALUES(" _
& i & ", " & x1 & ", " & x2 & ")"
Range("F1").Value = Qry
End If
Next
End SubPrivate Sub Test_NhoXuLy()
Dim Arr(), i As Long, j As Long, n
Dim Res(), x1, x2
Dim Qry As String
Arr = Range("E4:I100").Value ''mang nay co the then nhieu cot hay giam bot
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) <> "" Then
For j = 1 To UBound(Arr, 2) ''duyet For i, J lam sao cho no lay tuong ung voi so cot cua mang
'x1 = GetValue(Arr(i, 1))
'x2 = GetValue(Arr(i, 2)) ''Bo het kieu nay
'MsgBox " OK" ''Gan mang Arr(i,j) lam sao vao Qry noi cac chuoi lai voi nhau nhu sub Test_Mau
Qry = "INSERT INTO Manh2 VALUES(" _
& i & ", " & x1 & ", " & x2 & ")"
Range("F2").Value = Qry ''Cac chuoi sau khi noi lai trong mang
Next
End If
Next
End SubMình đang suy nghĩ là nếu ta không sử dụng phương thức insert ... mà ta sử dụng phương thức sau
Rst.Open tableName, MyString, adOpenStatic, adLockOptimistic
For i = 1 To UBound(Res, 1)
Rst.AddNew
For j = 1 To Rst.Fields.Count - 1
Rst.Fields(j) = Res(i, j)
Next j
Next i
Rst.Update
