Bổ sung thêm cột hiển thị tên sh

[thang24]

Mình có file dữ liệu.
Đã gộp dữ liệu hết các sh vào data bằng VBA,
Nhung mình chưa biết cách tạo thêm cột G trong data sao cho: o cột G phải thể hiện tên Sh mà dữ liệu đã lấy tương ứng.
Vậy mong các bạn chỉ bảo júp.

 

[Hai Lúa Miền Tây]

Mình có file dữ liệu.
Đã gộp dữ liệu hết các sh vào data bằng VBA,
Nhung mình chưa biết cách tạo thêm cột G trong data sao cho: o cột G phải thể hiện tên Sh mà dữ liệu đã lấy tương ứng.
Vậy mong các bạn chỉ bảo júp.

Bạn thử chạy code sau nhé:

Sub DATA()
Dim WSh As Worksheet
[B][COLOR=Blue]Dim dong As Long[/COLOR][/B]
Sheets("DATA").Cells.Clear
Sheets("DATA").Range("A5:F5") = Sheets("N1").Range("A5:F5").Value
For Each WSh In ThisWorkbook.Worksheets
    If WSh.Name <> "Data" Then
        [B][COLOR=Blue]dong = Sheets("DATA").Range("A65536").End(xlUp).Row + 1
        Sheets("Data").Cells(dong, "g").Resize(WSh.[A6].CurrentRegion.Offset(2).Rows.Count).Value = WSh.Name[/COLOR][/B]
        WSh.[A6].CurrentRegion.Offset(2).Copy Destination:=Sheets("DATA").Range("A" [B][COLOR=Blue]& dong[/COLOR][/B])

    End If
Next WSh

End Sub

 

[ndu96081631]

Mình có file dữ liệu.
Đã gộp dữ liệu hết các sh vào data bằng VBA,
Nhung mình chưa biết cách tạo thêm cột G trong data sao cho: o cột G phải thể hiện tên Sh mà dữ liệu đã lấy tương ứng.
Vậy mong các bạn chỉ bảo júp.

Code của bạn tôi sửa thành thế này:

Sub DATA()
  Dim Wsh As Worksheet, Rng As Range
  Sheets("DATA").Cells.Clear
  Sheets("DATA").Range("A5:F5") = Sheets("N1").Range("A5:F5").Value
  For Each Wsh In ThisWorkbook.Worksheets
    If Wsh.Name <> "DATA" Then
      With Wsh.Range("A7").CurrentRegion
        Set Rng = Sheets("DATA").Range("A" & [B65500].End(xlUp).Row + 1)
        Rng.Resize(.Rows.Count, .Columns.Count) = .Value
        Rng.Offset(, 6).Resize(.Rows.Count) = Wsh.Name
      End With
    End If
  Next Wsh
End Sub

 

[thang24]

domfootwear thân mến! trong data vẫn thừa ra 2 dòng N4 (tại cột G)?

 

[Hai Lúa Miền Tây]

domfootwear thân mến! trong data vẫn thừa ra 2 dòng N4 (tại cột G)?

Do nó đếm 1 dòng tiêu đề và 1 dòng bị ẩn. Vậy thì - ra 2 dòng là được

Sub DATA()
Dim WSh As Worksheet
Dim dong As Long
Sheets("DATA").Cells.Clear
Sheets("DATA").Range("A5:F5") = Sheets("N1").Range("A5:F5").Value
For Each WSh In ThisWorkbook.Worksheets
    If WSh.Name <> "Data" Then
        dong = Sheets("DATA").Range("A65536").End(xlUp).Row + 1
        Sheets("Data").Cells(dong, "g").Resize(WSh.[A6].CurrentRegion.Offset(2).Rows.Count [B][COLOR=Red]- 2[/COLOR][/B]).Value = WSh.Name
        WSh.[A6].CurrentRegion.Offset(2).Copy Destination:=Sheets("DATA").Range("A" & dong)

    End If
Next WSh

End Sub

 

[ndu96081631]

domfootwear thân mến! trong data vẫn thừa ra 2 dòng N4 (tại cột G)?

Thừa là vì bạn xác định vùng dữ liệu tại các sheet con sai ---> Sai ở chổ Offset(2) ấy ---> Nó sẽ bị 2 dòng thừa dưới cùng
Dòng 6 tại các sheet con đang trống, vậy cớ sao phải [A6].CurrentRegion rồi lại Offsect(2)
sao không là [A7].CurrentRegion ---> Vừa đủ, không thừa không thiếu

 

[thang24]

Chân thành cảm ơn! vậy mà từ hôm qua mình cứ loay hoay mãi!
@ mình tìm mãi "trên diển đàn này cũng có code thay cho FileSearch" nhưng không thấy! mĩnh sẽ tìm tiếp xem sao? không đợc ndu chỉ júp nhé!

 

[ndu96081631]

Chân thành cảm ơn! vậy mà từ hôm qua mình cứ loay hoay mãi!
@ mình tìm mãi "trên diển đàn này cũng có code thay cho FileSearch" nhưng không thấy! mĩnh sẽ tìm tiếp xem sao? không đợc ndu chỉ júp nhé!

Xem code thay cho FileSearch tại đây nhé:
http://www.giaiphapexcel.com/forum/showthread.php?25782-Duy%E1%BB%87t-file-Excel-trong-sub-folder
Ngoài ra còn có 1 cách hay hơn rất nhiều, đó là dùng hàm FILES trong Macro 4 (với điều kiện không tìm file trong thư mục con và số lượng file không vượt quá 256 files) ---> Cách này tìm 1 cái ra ngay mà không cần dùng đến vòng lập

 

[SA_DQ]

Thế ni mới đỡ bị lỗi nè

Option Explicit
Sub CopyToData()
 Dim Sh As Worksheet, Rng As Range, RngD As Range
 Dim Color_ As Byte
 
 Sheets("Data").Select:                         [G5].Value = "SheetName"
 [a5].CurrentRegion.Offset(1).ClearContents
 Color_ = [a5].Interior.ColorIndex + 1
 If Color_ < 34 Or Color_ > 41 Then Color_ = 35
 For Each Sh In ThisWorkbook.Worksheets
   If Sh.Name <> "Data" Then
      Set Rng = Sh.[A6].CurrentRegion.Offset(2)
      Set RngD = [A65500].End(xlUp).Offset(1)
      Rng.Copy Destination:=RngD
      With RngD.Offset(, Rng.Columns.Count).Resize(Rng.Rows.Count - 2)
         .Value = Sh.Name
      End With
   End If
 Next Sh
 [a5].Interior.ColorIndex = Color_
End Sub

Trong trang tính của bạn không có trang DATA, chỉ có trang Data mà thôi.
Không biết sao nhưng máy mình nó yêu cầu fải viết đúng như vậy nó mới chịu(?).