Nhờ Anh Chị Giúp Đỡ Rút Ngắn Đoạn Code

Liên hệ QC
G

Gà gà

Thành viên mới
Tham gia
28/12/20
Bài viết
25
Được thích
2
Xin chào anh chị, nhờ các anh chị giúp dùm em rút ngắn đoạn code dưới đây.
Em có 1 file , trong file đó có sheet tên là lệnh cắt.
Trong sheet lệnh cắt có 2 cột, cột C là mã hàng và cột D là số lượng. và ô E5 là ngày
Em muốn copy data của cột C,D và E5 qua một file khác có tên sheet là cutting.
Em có chạy đoạn code dưới đây nhưng nó hơi rườm rà.
Anh chị nào có cách rút gọi vui lòng chỉ giúp em với ạ, em xin cảm ơn.
Dưới đây là đoạn code của em ạ
Sub COPY_dulieu()

Application.ScreenUpdating = False

Dim lastrow As Integer
Dim last As Integer
Dim ls As Integer
Dim lr As Integer
Dim dc As Integer

lastraw = Worksheets("lenh cat").Cells(Rows.Count, 2).End(xlUp).Row
Range("C7:C" & lastraw).Copy
Workbooks.Open Filename:="\\C:\Users\Pro.Hien\desktop\wire inventory checking\production record 2022.xlsx", UpdateLinks:=0

Sheets("cutting").Select
lr = Worksheets("cutting").Cells(Rows.Count, 2).End(xlUp).Row + 1
Range("B" & lr).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks("production record 2022").Save
Workbooks("production record 2022").Close

last = Worksheets("lenh cat").Cells(Rows.Count, 3).End(xlUp).Row
Range("D7: D" & last).Copy
Workbooks.Open Filename:="\\C:\Users\Pro.Hien\desktop\wire inventory checking\production record 2022.xlsx", UpdateLinks:=0

ls = Worksheets("cutting").Cells(Rows.Count, 4).End(xlUp).Row + 1
Range("D" & lr).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks("production record 2022").Save
Workbooks("production record 2022").Close

Range("E5").Copy
Workbooks.Open Filename:="\\C:\Users\Pro.Hien\desktop\wire inventory checking\production record 2022.xlsx", UpdateLinks:=0

dc = Worksheets("cutting").Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & dc).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks("production record 2022").Save
Workbooks("production record 2022").Close
Application.ScreenUpdating = True

End Sub
 
Lần chỉnh sửa cuối:
Gà gà đã viết:
Xin chào anh chị, nhờ các anh chị giúp dùm em rút ngắn đoạn code dưới đây.
Em có 1 file , trong file đó có sheet tên là lệnh cắt.
Trong sheet lệnh cắt có 2 cột, cột C là mã hàng và cột D là số lượng. và ô E5 là ngày
Em muốn copy data của cột C,D và E5 qua một file khác có tên sheet là cutting.
Em có chạy đoạn code dưới đây nhưng nó hơi rườm rà.
Anh chị nào có cách rút gọi vui lòng chỉ giúp em với ạ, em xin cảm ơn.
Dưới đây là đoạn code của em ạ
View attachment 277133
Nhấp chuột vào đây để mở rộng...
Như đùa ấy nhỉ? Bạn nhờ sửa code mà để hình ảnh thế kia. Rồi ai rảnh ngồi gõ lại toàn bộ để sửa cho bạn nào. File đính kèm không có. Bạn cũng phải nghĩ cho người khác nữa chứ
 
Ngày mai em đi cho đủ 5 từ.

www.giaiphapexcel.com

Trùng: Nhờ Anh Chị Giúp Đỡ Rút Ngắn Đoạn Code

Xin chào anh chị, nhờ các anh chị giúp dùm em rút ngắn đoạn code dưới đây. Em có 1 file , trong file đó có sheet tên là lệnh cắt. Trong sheet lệnh cắt có 2 cột, cột C là mã hàng và cột D là số lượng. và ô E5 là ngày Em muốn copy data của cột C,D và E5 qua một file khác có tên sheet là cutting...
www.giaiphapexcel.com www.giaiphapexcel.com
 
Thầy bói xem 'tướng ' cho voi nè:
Tạo vòng lặp cho chu trình Copy của bạn
Trong vòng lặp thì gọi chương trình con, giao cho nó 1 vài tham biến để xử nhiệm vụ cho bạn
& chúc thành công!
CỐ LÊN, CÔ CỐ LÊN, RÁNG LÊN ĐI BẠN!
 
Lần đầu gửi bài nên còn thiếu xót, mong các anh chị thông cảm
Em xin gửi lại đoạn code ạ
Sub COPY_dulieu()

Application.ScreenUpdating = False

Dim lastrow As Integer
Dim last As Integer
Dim ls As Integer
Dim lr As Integer
Dim dc As Integer

lastraw = Worksheets("lenh cat").Cells(Rows.Count, 2).End(xlUp).Row
Range("C7:C" & lastraw).Copy
Workbooks.Open Filename:="\\C:\Users\Pro.Hien\desktop\wire inventory checking\production record 2022.xlsx", UpdateLinks:=0

Sheets("cutting").Select
lr = Worksheets("cutting").Cells(Rows.Count, 2).End(xlUp).Row + 1
Range("B" & lr).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks("production record 2022").Save
Workbooks("production record 2022").Close

last = Worksheets("lenh cat").Cells(Rows.Count, 3).End(xlUp).Row
Range("D7:D" & last).Copy
Workbooks.Open Filename:="\\C:\Users\Pro.Hien\desktop\wire inventory checking\production record 2022.xlsx", UpdateLinks:=0

ls = Worksheets("cutting").Cells(Rows.Count, 4).End(xlUp).Row + 1
Range("D" & lr).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks("production record 2022").Save
Workbooks("production record 2022").Close

Range("E5").Copy
Workbooks.Open Filename:="\\C:\Users\Pro.Hien\desktop\wire inventory checking\production record 2022.xlsx", UpdateLinks:=0

dc = Worksheets("cutting").Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & dc).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Workbooks("production record 2022").Save
Workbooks("production record 2022").Close
Application.ScreenUpdating = True

End Sub

Mong các anh chị giúp đỡ
Bài đã được tự động gộp:

BuiQuangThuan đã viết:
Như đùa ấy nhỉ? Bạn nhờ sửa code mà để hình ảnh thế kia. Rồi ai rảnh ngồi gõ lại toàn bộ để sửa cho bạn nào. File đính kèm không có. Bạn cũng phải nghĩ cho người khác nữa chứ
Nhấp chuột vào đây để mở rộng...
Xin lỗi bạn, lần sau sẽ tốt hơn, mình có cập nhật đoạn code, xin bạn giúp đỡ
 
Lần chỉnh sửa cuối:
Gà gà đã viết:
Lần đầu gửi bài nên còn thiếu xót, mong các anh chị thông cảm
Em xin gửi lại đoạn code ạ

Mong các anh chị giúp đỡ
Bài đã được tự động gộp:


Xin lỗi bạn, lần sau sẽ tốt hơn, mình có cập nhật đoạn code, xin bạn giúp đỡ
Nhấp chuột vào đây để mở rộng...
Vấn đề là không những cần code của bạn (để sửa giúp bạn ) mà còn cần cả cái file có chứa code, thì người giúp mới biết là code lay ở đâu, copy những gì, paste vào đâu. Chức bạn chỉ đưa code lên và người cón đâu thời gian để tạo file, copy code vào , và sửa lại code cho bạn. Hãy đưa cái file có đoạn code trên lên đi. Còn không thì hãy nghiên cứu và làm theo hướng dẫn của Anh SA_DQ (bài #4)
 
Attach file và kết quả mong muốn...
Thường thì không ai sửa code cho bạn đâu ...mà thường viết lại code mới ...
Sau đó bạn tự ngâm cứu và rút kinh nghiệm cho lần sau ...
 
HUONGHCKT đã viết:
Vấn đề là không những cần code của bạn (để sửa giúp bạn ) mà còn cần cả cái file có chứa code, thì người giúp mới biết là code lay ở đâu, copy những gì, paste vào đâu. Chức bạn chỉ đưa code lên và người cón đâu thời gian để tạo file, copy code vào , và sửa lại code cho bạn. Hãy đưa cái file có đoạn code trên lên đi. Còn không thì hãy nghiên cứu và làm theo hướng dẫn của Anh SA_DQ (bài #4)
Nhấp chuột vào đây để mở rộng...
Xin cảm ơn ý kiến góp ý của bạn
Bài đã được tự động gộp:

Tống Văn Đệ đã viết:
Attach file và kết quả mong muốn...
Thường thì không ai sửa code cho bạn đâu ...mà thường viết lại code mới ...
Sau đó bạn tự ngâm cứu và rút kinh nghiệm cho lần sau ...
Nhấp chuột vào đây để mở rộng...
xin cảm ơn ý kiến góp ý của bạn
 

File đính kèm

  • value.xlsm
    9.9 KB · Đọc: 9
  • Practice.xlsm
    9.6 KB · Đọc: 10
Gà gà đã viết:
Mình xin gửi file attach. Bạn vui lòng xem xét và giúp đỡ mình nha
Nhấp chuột vào đây để mở rộng...
Dùng code này cho file Practice.com
Mã: 
Sub COPY_dulieu()
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim aWs As Worksheet
    Dim lastRow As Integer
    Dim last As Integer
    
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xls*"
        .Title = "Chon File Excel can them du lieu"
        If .Show = True Then
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            Set aWs = Sheet1
            lastRow = Sheet1.Range("B10000").End(xlUp).Value2
            Set Wb = Workbooks.Open(.SelectedItems(1))
            Set Ws = Wb.Sheets("cutting")
            last = Ws.Range("A65000").End(xlUp).Row + 1
            Ws.Range("A" & last).Resize(lastRow).Value2 = aWs.Range("E2").Value2
            Ws.Range("A" & last).Resize(lastRow).NumberFormat = "d-mmm"
            Ws.Range("B" & last).Resize(lastRow).Value2 = aWs.Range("C4").Resize(lastRow).Value2
            Ws.Range("D" & last).Resize(lastRow).Value2 = aWs.Range("D4").Resize(lastRow).Value2
            Wb.Save
            Wb.Close
            Set Ws = Nothing
            Set aWs = Nothing
            Set Wb = Nothing
            Application.DisplayAlerts = True
            Application.ScreenUpdating = True
            MsgBox "Da copy du lieu thanh cong"
        End If
    End With
End Sub
 
giaiphap đã viết:
Dùng code này cho file Practice.com
Mã: 
Sub COPY_dulieu()
    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim aWs As Worksheet
    Dim lastRow As Integer
    Dim last As Integer
   
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xls*"
        .Title = "Chon File Excel can them du lieu"
        If .Show = True Then
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            Set aWs = Sheet1
            lastRow = Sheet1.Range("B10000").End(xlUp).Value2
            Set Wb = Workbooks.Open(.SelectedItems(1))
            Set Ws = Wb.Sheets("cutting")
            last = Ws.Range("A65000").End(xlUp).Row + 1
            Ws.Range("A" & last).Resize(lastRow).Value2 = aWs.Range("E2").Value2
            Ws.Range("A" & last).Resize(lastRow).NumberFormat = "d-mmm"
            Ws.Range("B" & last).Resize(lastRow).Value2 = aWs.Range("C4").Resize(lastRow).Value2
            Ws.Range("D" & last).Resize(lastRow).Value2 = aWs.Range("D4").Resize(lastRow).Value2
            Wb.Save
            Wb.Close
            Set Ws = Nothing
            Set aWs = Nothing
            Set Wb = Nothing
            Application.DisplayAlerts = True
            Application.ScreenUpdating = True
            MsgBox "Da copy du lieu thanh cong"
        End If
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Xin cảm ơn bạn rất nhiều !
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

hongphuong1997
  • Question
Lấy ký tự trong chuỗi theo nhiều điều kiện
Trả lời
5
Đọc
83
CHAOQUAY
C
phuyen89
  • Question
Hạn chế số ngày sử dụng của File
2
Trả lời
38
Đọc
10K
nguyentan85
N
NguyenNhan789556
  • Question
Viết code trong VBA
Trả lời
1
Đọc
12
BuiQuangThuan
B
xkun2001
  • Question
Nhờ sửa code get hyperlink
Trả lời
0
Đọc
1
xkun2001
xkun2001
nquanglam1987
Hỏi về VBA match và index để tăng tốc xử lí dữ liệu
Trả lời
2
Đọc
88
hoangtuan.net
hoangtuan.net
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom