Làm sao để lấy dữ liệu từ 1 sheet vào 1 sheet (khác workbook)

[hieplv3010]

Tui nghĩ vấn đề này cũng đâu có gì khó mà.
Ví dụ:
1. Trong workbook anh có 3 sheet TH, và 20 sheet Trường. Sheet TH thì link các sheet Trường.
2. Anh dùng Move or Copy.. để move mỗi trường thành 1 file riêng (nhớ không click vào ô "create a copy" - vì anh move sheet thành file chứ không copy)
3. Khi anh save file từng trường lưu ý file chứa sheet TH đang mở. Sau đó save file TH này. (Như vậy file TH này đang link đến 20 file các Trường)
4. Anh copy 20 file đó gởi đi 20 trường.
5. Khi họ chuyển trả lại, anh chỉ copy file của từng Trường vào thư mục anh lưu ban đầu (copy và lưu chồng lên)
6. Anh mở file TH, file từng trường, thì lúc này khi anh mở file Trường nào, thì file TH đã link vào. Anh save file TH lại và làm báo cáo TH cũng được. Còn không thì anh vào file từng Trường, chọn move a copy, và move về file TH (không chọn "create a copy"). Như vậy là xong.

* Còn bây giờ lúc trước anh lỡ copy rồi, thì anh lấy file Mẫu ban đầu ra, thực hiện lại bước 2, 3.
Sau đó lấy file các đơn vị gởi về, copy và save chồng lên (thực hiện các bước 5, 6.)

Vài ý kiến đóng góp với anh.
Thân!

 

[tedaynui]

@ Gởi Hieplv3010
Thật ra theo góp ý của bạn thì Dvu58 đã thực hiện lâu nay. Nhưng nếu làm như vậy thì có rất nhiều yếu điểm : vô cùng vất vả, nhiều công sức và dễ sai sót. Các file có dung lượng lớn, đôi khi lại gặp lỗi liên kết.....

Mình đã gởi file cho Dvu58 (xin lỗi, vì dung lượng file lớn nên gởi qua mail - thật ra cũng gần giống như file ví dụ mà mình đã Up ở bài #12) và chắc Dvu58 cũng đang làm cho nó hoàn thiện hơn. Vì không chuyên nên rất chuối nhưng trước mắt chỉ cần giải quyết được vấn đề cho công việc nhẹ nhàng hơn tí qua cú nhấp chuột. Từ việc tự tạo file Tkê mẫu cho các trường, việc cập nhật số liệu từ các file đang đóng ...

@ Mong Anh Dvu58 bổ sung và góp ý thêm.

Thân!
TDN

 

[dvu58]

Tui nghĩ vấn đề này cũng đâu có gì khó mà.
Ví dụ:
1. Trong workbook anh có 3 sheet TH, và 20 sheet Trường. Sheet TH thì link các sheet Trường.
2. Anh dùng Move or Copy.. để move mỗi trường thành 1 file riêng (nhớ không click vào ô "create a copy" - vì anh move sheet thành file chứ không copy)
3. Khi anh save file ..........

hieplv3010 thân.

Cách làm như vậy mình đã có trình bày sơ khởi ban đầu, rất nhiều khó khăn, không hiệu quả đâu.

Bạn tedaynui đã có cách làm rất hay (kể cả ý tưởng và kỹ thuật, không "củ chuối" chút nào đâu!) và đã có bài gởi giới thiệu ý tưởng, bạn xem thử. Tất nhiên là khi áp dụng vào từng điều kiện, hoàn cảnh cụ thể theo địa phương của mình bạn cần phải điều chỉnh cho phù hợp.

Chỉ cần bấm nút 1 phát là .....OK, xong hết.

Cảm ơn bạn tedaynui nhiều lắm lắm.
Thân.

 

[dvu58]

Tiếp theo vấn đề lấy dữ liệu từ sheet vào sheet

Xin post thành quả của tedaynui và của mình lên chia sẻ cùng các bạn nhé!

* Sau khi nhận các file báo cáo (đã có dữ liệu) từ các trường gởi lên, copy vào thư mục DATA - Sau đó nhấn vào nút "cập nhật dữ liệu"

 

[tedaynui]

Ủa sao hôm trước File gần 2Mb, sao hôm nay còn 174Kb vậy ta ? Hỏng lẻ mình nhìn nhầm. (???)

 

[hieplv3010]

File rất hay, cám ơn tedaynui và dvu58 đã post bài.

 

[kelvin]

....Nhưng mình còn băn khoăn bởi các vấn đề sau:
1. Các ô (vùng) dữ liệu thô rời rạc, không liên tục xen kẽ với các vùng công thức tính toán, xử lý có trong mỗi Sheet.
.........
Thân

Không biết có hiểu đúng ý bạn khg? Nhưng theo tôi, khi dữ liệu thô rời rạc, không liên tục thì ta vẫn copy từng vùng vậy, có thể code không đẹp nhưng vẫn giải quyết được.
Còn để code đẹp hơn ta dùng Copy.Areas.

Sub copy_2_PasteSpecial()
    Dim destrange As Range
    Dim smallrng As Range
    Application.ScreenUpdating = False
    For Each smallrng In Sheets("Sheet1"). _
        Range("a1:c10,e12:g17").Areas
        Set destrange = Sheets("Sheet2").Range("A" & _
                        LastRow(Sheets("Sheet2")) + 1)
        smallrng.Copy
        destrange.PasteSpecial xlPasteValues, , False, False
        Application.CutCopyMode = False
    Next smallrng
    Application.ScreenUpdating = True
End Sub
 

Sub copy_2_Values_ValueProperty()
    Dim destrange As Range
    Dim smallrng As Range
    For Each smallrng In Sheets("Sheet1"). _
        Range("a1:c10,e12:g17").Areas
        With smallrng
            Set destrange = Sheets("Sheet2").Range("A" & _
                LastRow(Sheets("Sheet2")) + 1).Resize( _
                .Rows.Count, .Columns.Count)
        End With
        destrange.Value = smallrng.Value
    Next smallrng
End Sub

Hai đoạn code trên của http://www.rondebruin.nl/tips.htm

 

[kelvin]

Còn muốn copy Areas mà vẫn giử được vị trí tương đối giửa source va dest thì có thể tham khảo code của j-walk

Option Explicit

Sub CopyMultipleSelection()
    Dim SelAreas() As Range
    Dim PasteRange As Range
    Dim UpperLeft As Range
    Dim NumAreas As Integer, i As Integer
    Dim TopRow As Long, LeftCol As Integer
    Dim RowOffset As Long, ColOffset As Integer
    Dim NonEmptyCellCount As Integer
    
'   Exit if a range is not selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select the range to be copied. A multiple selection is allowed."
        Exit Sub
    End If
    
'   Store the areas as separate Range objects
    NumAreas = Selection.Areas.Count
    ReDim SelAreas(1 To NumAreas)
    For i = 1 To NumAreas
        Set SelAreas(i) = Selection.Areas(i)
    Next
    
'   Determine the upper left cell in the multiple selection
    TopRow = ActiveSheet.Rows.Count
    LeftCol = ActiveSheet.Columns.Count
    For i = 1 To NumAreas
        If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
        If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
    Next
    Set UpperLeft = Cells(TopRow, LeftCol)
    
'   Get the paste address
    On Error Resume Next
    Set PasteRange = Application.InputBox _
      (Prompt:="Specify the upper left cell for the paste range:", _
      Title:="Copy Mutliple Selection", _
      Type:=8)
    On Error GoTo 0
'   Exit if canceled
    If TypeName(PasteRange) <> "Range" Then Exit Sub

'   Make sure only the upper left cell is used
    Set PasteRange = PasteRange.Range("A1")
    
'   Check paste range for existing data
    NonEmptyCellCount = 0
    For i = 1 To NumAreas
        RowOffset = SelAreas(i).Row - TopRow
        ColOffset = SelAreas(i).Column - LeftCol
        NonEmptyCellCount = NonEmptyCellCount + _
            Application.CountA(Range(PasteRange.Offset(RowOffset, ColOffset), _
            PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1, _
            ColOffset + SelAreas(i).Columns.Count - 1)))
    Next i
    
'   If paste range is not empty, warn user
    If NonEmptyCellCount <> 0 Then _
        If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
        "Copy Multiple Selection") <> vbYes Then Exit Sub

'   Copy and paste each area
    For i = 1 To NumAreas
        RowOffset = SelAreas(i).Row - TopRow
        ColOffset = SelAreas(i).Column - LeftCol
        SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
    Next i
End Sub

 

[kelvin]

Nếu không muốn open file, mà chỉ lấy dử liệu thì dùng thử (cũng của j-walk)

Option Explicit


Private Function GetValue(path, file, sheet, ref)
'   Retrieves a value from a closed workbook
'path:  The drive and path to the closed file (e.g., "d:\files")
'file:  The workbook name (e.g., "99budget.xls")
'sheet: The worksheet name (e.g., "Sheet1")
'ref:   The cell reference (e.g., "C4")

    Dim arg As String

'   Make sure the file exists
    If Right(path, 1) <> "\" Then path = path & "\"
    If Dir(path & file) = "" Then
        GetValue = "File Not Found"
        Exit Function
    End If

'   Create the argument
    arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
      Range(ref).Range("A1").Address(, , xlR1C1)

'   Execute an XLM macro
    GetValue = ExecuteExcel4Macro(arg)
End Function
Sub TestGetValue()
'D:\PTC  CloseIniFileToVBA.xls Sheet1 B3

Dim p As String, f As String, s As String, a As String
    p = "D:\PTC"
    f = "CloseIniFileToVBA.xls"
    s = "Sheet1"
    a = "B3"
    MsgBox GetValue(p, f, s, a)
End Sub
Sub TestGetValue2()
 'reads 1,200 values (100 rows and 12 columns) from a closed file, and places the values into the active worksheet.
    Dim p As String, f As String, s As String, a As String
    Dim r As Integer, c As Integer
    'hay lam , dung file de dua may cai duong dan, ten file nay vao 18Oct2007
    p = "D:\PTC"
    f = "CloseIniFileToVBA.xls"
    s = "Sheet1"
    Application.ScreenUpdating = False
    For r = 1 To 100
        For c = 1 To 12
            a = Cells(r, c).Address
            Cells(r, c) = GetValue(p, f, s, a)
        Next c
    Next r
    Application.ScreenUpdating = True
End Sub
Sub thu()
Dim ref
'Range("A1").Address(, , xlR1C1) 'bi loi
'ref = Range("b1").Range("A1").Address(, , xlR1C1) '  : ref : "R1C2" : Variant/String
ref = Range("A1").Address(, , xlR1C1) '  : ref : "R1C1" : Variant/String
End Sub