Nhờ các anh chị giúp đỡ: Tìm kiếm, Copy và Paste

  • Thread starter Thread starter bakakun
  • Ngày gửi Ngày gửi
Liên hệ QC

bakakun

Thành viên mới
Tham gia
1/11/09
Bài viết
2
Được thích
0
Chào các anh chị!
Hiện tại em đang gặp phải 1 vấn đề khó khăn mà chưa nghĩ ra cách giải quyết triệt để muốn nhờ các anh chị giúp em. Vấn đề của em như sau:

- Người dùng nhập 1 chuỗi ký tự (theo quy định trước) để lấy ra thông tin cần thiết
- Copy template (format, color...) từ sheet Template về sheet đích (Template Tool)
- Copy nội dung tương ứng với template này về sheet đích tại vị trí đang đặt con trỏ (Template Tool)
- Khi thay đổi nội dung của các sheet Content và Template thì ở sheet đích cũng thay đổi theo.

VD: nhập chuỗi "M 065" thì sẽ copy ở sheet Template 1 range(X, Y) tương ứng với mã M; Copy ở sheet Content nội dung tương ứng với mã 065; Paste vào sheet Template Tool các nội dung tương ứng.

Hiện tại em đang giải quyết 3 vấn đề đầu tiên nhưng mà vẫn chưa được hoàn chỉnh (có thể copy được template nhưng lại chưa copy được content) và chưa paste vào vị trí mong muốn được. Vấn đề thứ 4 thì em chưa nghĩ ra hướng giải quyết ra làm sao :(. Em xin gửi kèm theo code e đã viết mong anh chị giúp em.
---------------------------------------------------------------------------------
Sub Test()
Dim ins As String
Dim inty() As String


ins = Application.InputBox(Prompt:="Select template type", Title:="String Value")
If ins = " " Then Exit Sub
inty = Split(ins, " ")


If inty(0) = "m" Then
Sheets("Template").Select
Range("A1:E2").Select
Selection.Copy

Sheets("Template Tool").Select
Range("A1:E2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

ActiveCell.Select
ActiveCell.Offset(-1).Value = Application.WorksheetFunction.VLookup(inty(1), Sheets("Content").Range("A1:E1"), 1, 0)
ActiveCell.Offset(-1, 1).Value = Application.WorksheetFunction.VLookup(inty(1), Sheets("Content").Range("A1:E1"), 2, 0)
ActiveCell.Offset(-1, 2).Value = Application.WorksheetFunction.VLookup(inty(1), Sheets("Content").Range("A1:E1"), 3, 0)
ActiveCell.Offset(-1, 3).Value = Application.WorksheetFunction.VLookup(inty(1), Sheets("Content").Range("A1:E1"), 4, 0)
End If


End Sub
----------------------------------------------------------------------------
P/S: nếu thực hiện được những việc này bằng hàm (Function) thì tốt nhất ạ vì nhỡ có bị block macro vần xài đc :D. Cảm ơn các anh chị.
 

File đính kèm

Hiz, sao hiu hắt vậy nè, em đã giải quyết được 3 vấn đầu:
------------------------------------------------------------------------
Sub copy_table()
Dim sw, dw, ash, dsh1(2), dsh2(2), dsh3(2), rgsrch As String
Dim i, j, k, pathlen, col, frow As Integer
Dim fval, sval, urow, ucol As Variant
Dim rgsearch, rginsert As Range
Dim tbid, tbdes, tbcls, tbkey(), tbnull(), fname(), fdes(), elem(), ftype(), ilen() As Variant
Dim ifname, tbname, lname, sdir, xfname As String
Dim ipath, iget, itemp, sshape, rgupd As String
Dim ws As Worksheet
Dim oShape As Object


On Error Resume Next
sw = Application.ActiveWorkbook.Name
ash = ActiveWorkbook.ActiveSheet.Name


'lay duong dan cua file
iget = ActiveWorkbook.FullName
istr = Split(iget, "\")
pathlen = UBound(istr)
For i = 0 To pathlen
If istr(i) = sw Then
j = i - 1
End If
Next i
For i = 0 To j
If i = j Then
ipath = ipath & istr(i)
Else
ipath = ipath & istr(i) & "\"
End If
Next i


Windows(sw).Activate
Sheets(ash).Select
frow = Cells(65536, 1).End(xlUp).Row
Set rgsearch = Range("B3:X5000")


isstr = Range("AG4").Value
'tao workbook moi, co van de la neu nhu ko cung ngon ngu tieng nhat thi co kha nang ko lay dc
'do do nen de file template tieng anh (dinh cung' ten la template) de co the lam viec trong moi truong hop
New_window:
fval = ActiveCell.Value
col = 2
tbname = Application.WorksheetFunction.VLookup(fval, rgsearch, col, 0)
If tbname = "" Then
Exit Sub
End If
outname = "(" & tbname & ")"
ifname = Range("AG3").Value 'thay doi thanh chu tieng nhat
lname = "_B20408_v00.01_guidline.xls"
sdir = ipath & "\"
xfname = sdir & ifname & " " & outname & lname
itemp = "Template.xls"
'itemp = ifname & "(ZQUxxx)" & lname

Workbooks.Add Template:=ipath & "\" & itemp
ChDir ipath
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
Filename:=xfname, _
FileFormat:=xlExcel8, Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False


'lay ten sheet cua workbook moi tao ra
New_sheet:
dw = Application.ActiveWorkbook.Name
icheck = 0
For Each ws In Workbooks(dw).Worksheets
If icheck = 0 Then
dsh1(0) = ws.Name
dsh1(1) = ws.CodeName
ElseIf icheck = 1 Then
dsh2(0) = ws.Name
dsh2(1) = ws.CodeName
ElseIf icheck = 2 Then
dsh3(0) = ws.Name
dsh3(1) = ws.CodeName
End If
icheck = icheck + 1
Next


'xu ly hien thi cac sheet
Workbooks(dw).Activate
Sheet1:
For Each oShape In Worksheets(dsh1(0)).Shapes
sshape = oShape.TextFrame.Characters.Text
If (InStr(sshape, isstr) = 1) Then
'IName = oShape.Name
'Shapes(IName).Select
oShape.TextFrame.Characters.Text = isstr & vbCrLf & tbname
Exit For
End If
Next
Sheet3:
'tinh so field can insert
Windows(sw).Activate
Sheets(ash).Select
irow = ActiveCell.Row
rgnum = "B1" & ":" & "B" & frow
num = Application.WorksheetFunction.CountIf(Range(rgnum), fval)


'khoi tao lai cac mang chua thong tin
ReDim tbkey(num), tbnull(num), fname(num), fdes(num), elem(num), ftype(num), ilen(num) As Variant


'thuc hien insert vao workbook moi so dong can thiet
Windows(dw).Activate
For i = 1 To num - 1
Set rginsert = Sheets(dsh3(0)).Range("A11:Q11")
Sheets(dsh3(0)).Select
rginsert.Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
'Rows("11:11").Select
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
ActiveWorkbook.Save
'lay cac gia tri can thiet trong range [Bi:Xi] cua file table
Windows(sw).Activate
Sheets(ash).Select
k = 0
For i = irow To frow
Range("B" & i).Select
fval = ActiveCell.Value
sval = ActiveCell.Offset(1).Value
iactive = ActiveCell.Offset(1).Row

rgsrch = "B" & i & ":" & "X" & i
If tbid = "" Then
tbid = fval
End If

If tbdes = "" Then
col = 2
tbdes = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)
End If

If tbcls = "" Then
col = 4
tbcls = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)
End If

col = 15
tbkey(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)

col = 18
tbnull(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)
If tbnull(k) = "NG" Then
tbnull(k) = Range("AG5").Value
End If

col = 13
fname(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)

col = 14
fdes(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)

col = 21
elem(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)

col = 22
ftype(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)

col = 23
ilen(k) = Application.WorksheetFunction.VLookup(tbid, Range(rgsrch), col, 0)

'kiem tra xem da la dong cuoi cung chua
If i = frow Then
iclose = 1
End If
'kiem tra xem co phai van la table do ko
If fval <> sval Then
fval = sval
tbid = fval
Range("B" & iactive).Select
If k <> (num - 1) Then
Sheets(ash).Select.Range("AG8").Value = k & "field update/" & num & ",table id" & tbid
End If
GoTo Set_data
End If
k = k + 1
Next i
'set du lieu sang workbook moi
Set_data:
Windows(dw).Activate
Sheets(dsh3(0)).Select
'table id, cell A6
urow = 6
ucol = "A"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = tbid

'table description cell B6
urow = 6
ucol = "B"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = tbdes

'table class cell I6
urow = 6
ucol = "I"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = tbcls

For i = 0 To num - 1
'field name o cot A
urow = i + 10
ucol = "A"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = fname(i)
'field description o cot B
urow = i + 10
ucol = "B"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = fdes(i)
'table key o cot C
urow = i + 10
ucol = "C"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = tbkey(i)
'table null o cot D
urow = i + 10
ucol = "D"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = tbnull(i)
'data element cot H
urow = i + 10
ucol = "H"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = elem(i)
'data type cot J
urow = i + 10
ucol = "J"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = ftype(i)
'field lenth o cot K
urow = i + 10
ucol = "K"
rgupd = ucol & urow
Sheets(dsh3(0)).Range(rgupd).Value = ilen(i)
If i Mod 5 = 0 Then
ActiveWorkbook.Save
End If
Next i
ActiveWorkbook.Save
Windows(dw).Close
If iclose = 0 Then
GoTo New_window
Else
Exit Sub
End If
End Sub
-----------------------------------------------------------------------------------------


Các anh chị có thể giúp e vụ tự động cập nhật ko ạ :(, cái khó ở đây là ko biết người dùng đã copy những template và content đó vào vị trí nào trong sheet đích để chạy tự động cập nhật. Em đang có hướng dự định làm như vầy:
- Khi người dùng đó gọi thủ tục này thì mình sẽ lưu lại address của activecell đó (đg dẫn đầy đủ)
- Viết 1 thủ tục khác khi nào người dùng thay đổi 2 sheet nguồn và gọi hàm Update() thì tự động tìm những acctivecell và action tương ứng trc đó ở vị trí đó và thực hiện lại hàm trên.

Ý tưởng là vậy nhưng mà em chưa có hướng thực hiện, rất mong có anh chị nào giúp em...
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom