Code Tính giá trị cho vùng R6:U19 có kết quả giống vùng X6:AA19 (1 người xem)

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

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
L

lhthai

Thành viên thường trực
Tham gia
1/9/07
Bài viết
309
Được thích
27
Mình muốn kết quả vùng R6:U19 (phần tô màu xanh) giống vùng X6:AA19
Hiện tại đang dùng code sau nay muốn mở rộng thêm thì sữa như thế nào
Nhờ các anh chỉ dẫn
PHP: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J)
    Next J
Next I
    Range("L1:P5000,R1:U5000").ClearContents
    [L1].Resize(UBound(sArr, 1), 5) = sArr
    [R1].Resize(UBound(Arr, 1), C) = Arr
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Code bài này dùng hàm evaluate (dấu ngoặc vuông) để tính range. Hàm này chỉ hoạt động theo hằng tại chỗ (literals). Và vì vậy code phải viết trên trị tuyệt đối, theo từ ngữ lập trình là "magic numbers”.

loại code này là loại code viết cho nhanh, với điều kiện không nới rộng. Bây giờ bạn muốn nới rộng thì e rằng sửa hơi nhiều. Có khi viết lại còn dễ hơn.
 
Upvote 0
VetMini đã viết:
Code bài này dùng hàm evaluate (dấu ngoặc vuông) để tính range. Hàm này chỉ hoạt động theo hằng tại chỗ (literals). Và vì vậy code phải viết trên trị tuyệt đối, theo từ ngữ lập trình là "magic numbers”.

loại code này là loại code viết cho nhanh, với điều kiện không nới rộng. Bây giờ bạn muốn nới rộng thì e rằng sửa hơi nhiều. Có khi viết lại còn dễ hơn.
Nhấp chuột vào đây để mở rộng...
Anh có hướng dẫn để em lại code không
 
Upvote 0
lhthai đã viết:
Anh có hướng dẫn để em lại code không
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub copy()
[X6:AA19].ClearContents
Range([R6], [R5000].End(3)).Resize(, 4).copy
Range("X5000").End(3).Offset(2, 0).PasteSpecial
End Sub
chắc còn yêu cầu gì thêm chứ nhỉ, nếu copy bình thường dùng cái này chắc là được thôi bạn
 
Upvote 0
comet_1701 đã viết:
Mã: 
Sub copy()
[X6:AA19].ClearContents
Range([R6], [R5000].End(3)).Resize(, 4).copy
Range("X5000").End(3).Offset(2, 0).PasteSpecial
End Sub
chắc còn yêu cầu gì thêm chứ nhỉ, nếu copy bình thường dùng cái này chắc là được thôi bạn
Nhấp chuột vào đây để mở rộng...
ý mình không phải vậy
Khi nhấn nút lệnh thì cho kết quả trực tiếp tại vùng (L : U) còn cột (X :AA) là phần điều kiện muốn bổ sung thêm vào code.
 
Upvote 0
lhthai đã viết:
ý mình không phải vậy
Khi nhấn nút lệnh thì cho kết quả trực tiếp tại vùng (L : U) còn cột (X :AA) là phần điều kiện muốn bổ sung thêm vào code.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J)
    Next J
Next I
    Range("L1:P5000,R1:U5000,X6:AA5000").ClearContents
    [L1].Resize(UBound(sArr, 1), 5) = sArr
    [R1].Resize(UBound(Arr, 1), C) = Arr
    [R6].Resize(UBound(Arr, 1), C).Copy
    Range("X5000").End(3).Offset(2, 0).PasteSpecial
Application.ScreenUpdating = True
End Sub
Bạn thử vậy xem được không nhé
 
Lần chỉnh sửa cuối:
Upvote 0
comet_1701 đã viết:
Mã: 
Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J)
    Next J
Next I
    Range("L1:P5000,R1:U5000,X6:AA5000").ClearContents
    [L1].Resize(UBound(sArr, 1), 5) = sArr
    [R1].Resize(UBound(Arr, 1), C) = Arr
    [R6].Resize(UBound(Arr, 1), C).Copy
    Range("X5000").End(3).Offset(2, 0).PasteSpecial
Application.ScreenUpdating = True
End Sub
Bạn thử vậy xem được không nhé
Nhấp chuột vào đây để mở rộng...
ý mình cũng không phải vậy
Mình bổ sung lại file ban giúp mình nha.
 
Upvote 0
lhthai đã viết:
ý mình cũng không phải vậy
Mình bổ sung lại file ban giúp mình nha.
Nhấp chuột vào đây để mở rộng...
Mã: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J)
    Next J
Next I
    Sheet1.Range("L1:P5000,R1:U5000,X1:AC5000").ClearContents
    Sheet1.[L1].Resize(UBound(sArr, 1), 5) = sArr
    Sheet1.[R1].Resize(UBound(Arr, 1), C) = Arr
    Sheet1.[R1].Resize(UBound(Arr, 1), C).Copy
    Sheet1.[X5000].End(3).PasteSpecial
Application.ScreenUpdating = True
End Sub
Bạn xem thử cái này, mà mình thấy có khác gì đâu. Không biết bạn đã thử code chưa đã. Mình thử cả hai code đều đúng yêu cầu của bạn.
 
Upvote 0
comet_1701 đã viết:
Mã: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J)
    Next J
Next I
    Sheet1.Range("L1:P5000,R1:U5000,X1:AC5000").ClearContents
    Sheet1.[L1].Resize(UBound(sArr, 1), 5) = sArr
    Sheet1.[R1].Resize(UBound(Arr, 1), C) = Arr
    Sheet1.[R1].Resize(UBound(Arr, 1), C).Copy
    Sheet1.[X5000].End(3).PasteSpecial
Application.ScreenUpdating = True
End Sub
Bạn xem thử cái này, mà mình thấy có khác gì đâu. Không biết bạn đã thử code chưa đã. Mình thử cả hai code đều đúng yêu cầu của bạn.
Nhấp chuột vào đây để mở rộng...
Vùng X:AA là phần ví dụ kết quả mình mong muốn thôi.
kết tại cột R6=F6*F2/D6/E6
Code mình chỉ tính được R6=F6*F2 mình muốn bổ sung thêm phần màu đỏ
 
Upvote 0
Upvote 0
VetMini đã viết:
Đúng vậy. Lúc bạn hỏi ở bài #3, tôi đã nhận ra cách diễn tả yêu cầu nhỏ giọt cho nên tôi tránh dính líu tiếp.
Nhấp chuột vào đây để mở rộng...

Tôi đồng ý với bác VetMini, tôi đoán chừng cả các bạn có bài trả lời cũng chưa chắc hiểu rõ yêu cầu tác giả và thậm chí đến giờ tôi cũng chả hiểu ra làm sao? Một việc hết sức đơn giản và cần thiết là cân nhắc kiểm tra để có 1 câu hỏi đúng yêu cầu, dễ hiểu. Như vậy sẽ có sớm đáp án của anh em
 
Upvote 0
sealand đã viết:
Tôi đồng ý với bác VetMini, tôi đoán chừng cả các bạn có bài trả lời cũng chưa chắc hiểu rõ yêu cầu tác giả và thậm chí đến giờ tôi cũng chả hiểu ra làm sao? Một việc hết sức đơn giản và cần thiết là cân nhắc kiểm tra để có 1 câu hỏi đúng yêu cầu, dễ hiểu. Như vậy sẽ có sớm đáp án của anh em
Nhấp chuột vào đây để mở rộng...
File của mình lấy dự liệu từ sheet1 để tính kết quả cho sheet 2 mình chuyển sang code để giảm dung lượng file.
Code trên chỉ tính được phần nhân nay muốn bỏ sung thêm.
Do file có trên 1000 dòng và 200 cột dùng nhiều công thức thấy nặng.
Mình úp lại file.
 
Upvote 0
lhthai đã viết:
Nếu đơn giản thì các anh trên diễn đàn đã giải rồi
Nhấp chuột vào đây để mở rộng...
Đọc xong bài này mình hơi nản rồi đó.
Kể cả mình ko giải được cho bạn đi thì thiếu gì người giải được bài này
Cuối năm rồi ai cũng bận bạn ah, nên có thể có bài sẽ có phản hồi hơi lâu
Anh Sealand và VetMini phẩy tay cái là ra chứ gì. Hai bâc tiền bối đó. Đáng tuổi cha chú mình nên các anh ý bận là điều dễ hiểu thôi. Ngoài ra chưa kể rất nhiều cao thủ khác nữa
 
Upvote 0
lhthai đã viết:
File của mình lấy dự liệu từ sheet1 để tính kết quả cho sheet 2 mình chuyển sang code để giảm dung lượng file.
Code trên chỉ tính được phần nhân nay muốn bỏ sung thêm.
Do file có trên 1000 dòng và 200 cột dùng nhiều công thức thấy nặng.
Mình úp lại file.
Nhấp chuột vào đây để mở rộng...

Thử với 1000 dòng và 200 cột xem sao
PHP: 
Public Sub LuXuBu()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, C As Long, R As Long
With Sheet1
    sArr = .Range(.[D2], .[D65536].End(xlUp)).Resize(, .[F2].End(xlToRight).Column - 3).Value
End With
C = UBound(sArr, 2)
R = UBound(sArr, 1)
ReDim dArr(1 To R, 1 To C)
For I = 5 To R
    K = K + 1
    For J = 3 To C
        dArr(K, J - 2) = sArr(I, J) * sArr(1, J) / sArr(I, 1) / sArr(I, 2)
    Next J
Next I
    Sheets("Sheet2").[R6].Resize(R, C) = dArr
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Thấy bạn theo Topic nên tôi làm thử

Mã: 
Private Sub CommandButton1_Click()
Dim Mg1, Mg2, i As Long, j As Long, Cl As Long
Application.ScreenUpdating = False
Cl = [F3].End(xlToRight).Column
Mg1 = Range([A1], [A65536].End(xlUp)).Resize(, 6).Value2
Mg2 = Range([F1], [F65536].End(xlUp)).Resize(, Cl - 5).Value2
For i = 1 To UBound(Mg2, 1)
If i < 6 Then
Mg1(i, 6) = ""
Else
Mg1(i, 6) = 0
For j = 1 To (Cl - 6)
Mg2(i, j) = Mg2(i, j) * Mg2(2, j) / Mg1(i, 4) / Mg1(i, 5)
If j < ((Cl - 6) / 2) + 1 Then Mg1(i, 6) = Mg1(i, 6) + Mg2(i, j)
Next j
End If
Next i
Sheet3.Cells.ClearContents
Sheet3.[A1].Resize(UBound(Mg1, 1), 6) = Mg1
Sheet3.[G1].Resize(UBound(Mg2, 1), Cl - 5) = Mg2
Application.ScreenUpdating = True
End Sub

Bạn cứ thử thêm dòng cột xem sao. Mình hiểu là từ cột F trở đi có 2 vùng giống nhau về tiêu chí, cột F phần kết quả là sum của 1 phần
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
lhthai đã viết:
File của mình lấy dự liệu từ sheet1 để tính kết quả cho sheet 2 mình chuyển sang code để giảm dung lượng file.
Code trên chỉ tính được phần nhân nay muốn bỏ sung thêm.
Do file có trên 1000 dòng và 200 cột dùng nhiều công thức thấy nặng.
Mình úp lại file.
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J) / sArr(I, 4) / sArr(I, 5)
    Next J
Next I
    Range("L1:P5000,R1:U5000,X6:AA5000").ClearContents
    [L1].Resize(UBound(sArr, 1), 5) = sArr
    [R1].Resize(UBound(Arr, 1), C) = Arr
    [R6].Resize(UBound(Arr, 1), C).Copy
    Range("X5000").End(3).Offset(2, 0).PasteSpecial
Application.ScreenUpdating = True
End Sub
Bài này là ví dụ thôi bạn nhé
Mã: 
Arr(I, J) = Arr(I, J) * Arr(2, J) / [COLOR=#0000cd]sArr(I, 4) / sArr(I, 5)[/COLOR]
chỉ càn thêm vậy thôi chứ có gì đâu, hy vọng lần sau bạn nên có đề bài cụ thể hơn nhé
 
Upvote 0
Upvote 0
comet_1701 đã viết:
Mã: 
Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim sArr(), Arr(), I As Long, J As Long, C As Long
    C = [F3].End(xlToRight).Column - 5
    sArr = Range([A1], [A65536].End(xlUp)).Resize(, 5).Value2
    Arr = Range([F1], [F65536].End(xlUp)).Resize(, C).Value2
For I = 6 To UBound(Arr, 1)
    For J = 1 To C
        Arr(I, J) = Arr(I, J) * Arr(2, J) / sArr(I, 4) / sArr(I, 5)
    Next J
Next I
    Range("L1:P5000,R1:U5000,X6:AA5000").ClearContents
    [L1].Resize(UBound(sArr, 1), 5) = sArr
    [R1].Resize(UBound(Arr, 1), C) = Arr
    [R6].Resize(UBound(Arr, 1), C).Copy
    Range("X5000").End(3).Offset(2, 0).PasteSpecial
Application.ScreenUpdating = True
End Sub
Bài này là ví dụ thôi bạn nhé
Mã: 
Arr(I, J) = Arr(I, J) * Arr(2, J) / [COLOR=#0000cd]sArr(I, 4) / sArr(I, 5)[/COLOR]
chỉ càn thêm vậy thôi chứ có gì đâu, hy vọng lần sau bạn nên có đề bài cụ thể hơn nhé
Nhấp chuột vào đây để mở rộng...
Cái này rất đúng với mình mong muốn.
Cám ơn nhiều
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

L
Tính thời gian làm việc thực tế
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
627
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho
Trả lời
4
Đọc
108
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật
Trả lời
1
Đọc
57
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
108
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
218
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
159
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
315
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
286
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom