Cột bị mất công thức khi tham chiếu mảng

[hadoan-pap]

Kính gửi mọi người.

Em có 1 bài toàn như file đính kèm. SD1 và SD2 ở Sheet2 dc tham chiếu từ Sheet1 sang.

Nhưng khi tham chiếu sang thì e k hiểu sao cột " Total " ỏ Sheet2 bị mất hết công thức... e đang để cột đó có công thức " Sum " như trong file. Nhưng khi tham chiếu chạy lệnh như bên dưới thì cột đó bị mất công thức.

Mọi người xem và cho em biết cách sửa để cột " Total " không bị mất công thức với ạ.

E xin cảm ơn!

Sub Button1_Click()
Dim arr, arr1
Dim i, a As Long
arr = Sheet1.Range("A1:c" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
arr1 = Sheet2.Range("B2:G" & Sheet2.Range("B" & Rows.Count).End(xlUp).Row).Value 'lây giá tri vao mang
For i = 1 To UBound(arr1, 1)
'If arr1(i, 1) <> Empty Then
For j = 1 To UBound(arr, 1)
If UCase(arr1(i, 1)) = UCase(arr(j, 1)) Then
arr1(i, 4) = arr(j, 2)
arr1(i, 6) = arr(j, 3)
End If
Next j
'End If
Next i
Sheet2.Range("b2").Resize(UBound(arr1, 1), 6).Value = arr1 'gán giá tri tu mang vao sheet2
End Sub

 

[hadoan-pap]

đây nhé bạn mình bằng tuổi bạn thôi hi

Sub chuyen()
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:m" & .Range("b" & Rows.Count).End(xlUp).Row).Value
    For i = UBound(arr, 1) To 2 Step -1
       If UCase(arr(i, 1)) = UCase("Total") Then
          For j = 4 To 17
             For k = 2 To UBound(arr, 2)
             If UCase(arr(1, k)) = UCase(Cells(4, j)) Then
                 Sheets("sheet5").Cells(5, j).Value = arr(i, k)
             End If
            Next k
          Next j
          Exit For
       End If
    Next i
End With
End Sub

Dear bạn,

Trong file mình có thử lại di chuyển hang " Total " o sheet5 xuống dưới 1 vài hang thì chạy code bên dưới nó k tham chiếu đc.

K biết chỗ nào gán sai giá trị mà nó chạy sai vậy ?

Mình cam ơn !
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:n" & .Range("b" & Rows.Count).End(xlUp).Row).Value
arr1 = Sheets("Sheet5").Range("C4:r100").Value
For i = UBound(arr, 1) To 2 Step -1
If UCase(arr(i, 1)) = UCase("Total") Then
For j = 2 To UBound(arr1, 2)
For k = 2 To UBound(arr, 2)
If UCase(arr(1, k)) = UCase(arr1(1, j)) Then
arr1(7, j) = arr(i, k)
End If
Next k
Next j
Exit For
End If
Next i
End With
Sheets("Sheet5").Range("c10").Resize(2, UBound(arr1, 2)).Value = arr1

 

[hadoan-pap]

Dear bạn,

Trong file mình có thử lại di chuyển hang " Total " o sheet5 xuống dưới 1 vài hang thì chạy code bên dưới nó k tham chiếu đc.

K biết chỗ nào gán sai giá trị mà nó chạy sai vậy ?

Mình cam ơn !
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:n" & .Range("b" & Rows.Count).End(xlUp).Row).Value
arr1 = Sheets("Sheet5").Range("C4:r100").Value
For i = UBound(arr, 1) To 2 Step -1
If UCase(arr(i, 1)) = UCase("Total") Then
For j = 2 To UBound(arr1, 2)
For k = 2 To UBound(arr, 2)
If UCase(arr(1, k)) = UCase(arr1(1, j)) Then
arr1(7, j) = arr(i, k)
End If
Next k
Next j
Exit For
End If
Next i
End With
Sheets("Sheet5").Range("c10").Resize(2, UBound(arr1, 2)).Value = arr1

Dear bạn.

Mình đã xử lý đc lỗi ở trên rồi. Nhưng khi chạy code thì các hang từ 5 đến 9 ở sheet5 bị mất hết công thức ( như TH hôm trc ). file mình gửi như đính kèm... nhờ bạn sửa giúp mình 1 chút với nhé.

 

[snow25]

Dear bạn,

Trong file mình có thử lại di chuyển hang " Total " o sheet5 xuống dưới 1 vài hang thì chạy code bên dưới nó k tham chiếu đc.

K biết chỗ nào gán sai giá trị mà nó chạy sai vậy ?

Mình cam ơn !
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:n" & .Range("b" & Rows.Count).End(xlUp).Row).Value
arr1 = Sheets("Sheet5").Range("C4:r100").Value
For i = UBound(arr, 1) To 2 Step -1
If UCase(arr(i, 1)) = UCase("Total") Then
For j = 2 To UBound(arr1, 2)
For k = 2 To UBound(arr, 2)
If UCase(arr(1, k)) = UCase(arr1(1, j)) Then
arr1(7, j) = arr(i, k)
End If
Next k
Next j
Exit For
End If
Next i
End With
Sheets("Sheet5").Range("c10").Resize(2, UBound(arr1, 2)).Value = arr1

đây bạn xem nhé

Sub chuyen()
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:m" & .Range("b" & Rows.Count).End(xlUp).Row).Value
a = Sheets("sheet5").Range("c" & Rows.Count).End(xlUp).Row
b = Sheets("sheet5").Cells(4, Columns.Count).End(xlToLeft).Column
    For i = UBound(arr, 1) To 2 Step -1
       If UCase(arr(i, 1)) = UCase("Total") Then
          For j = 4 To b
             For k = 2 To UBound(arr, 2)
             If UCase(arr(1, k)) = UCase(Sheets("sheet5").Cells(4, j)) Then
                 Sheets("sheet5").Cells(a, j).Value = arr(i, k)
             End If
            Next k
          Next j
          Exit For
       End If
    Next i
End With
End Sub

 

[hadoan-pap]

đây bạn xem nhé

Sub chuyen()
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:m" & .Range("b" & Rows.Count).End(xlUp).Row).Value
a = Sheets("sheet5").Range("c" & Rows.Count).End(xlUp).Row
b = Sheets("sheet5").Cells(4, Columns.Count).End(xlToLeft).Column
    For i = UBound(arr, 1) To 2 Step -1
       If UCase(arr(i, 1)) = UCase("Total") Then
          For j = 4 To b
             For k = 2 To UBound(arr, 2)
             If UCase(arr(1, k)) = UCase(Sheets("sheet5").Cells(4, j)) Then
                 Sheets("sheet5").Cells(a, j).Value = arr(i, k)
             End If
            Next k
          Next j
          Exit For
       End If
    Next i
End With
End Sub

Dear bạn,

Mình thấy đoạn code trc đó bạn gửi dễ hiểu hơn đoạn này. Nhưng số cột k chỉ giới hạn ("b3:m") mà nó còn nh hơn nữa như dưới mình khai báo. Khi đó code chạy khá chậm bạn ạ. Với đoạn code bạn gửi bên trên mình cũng đã thử nhưng chạy vẫn hơi chậm khi số cột tăng lên nh.

Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:ba" & .Range("b" & Rows.Count).End(xlUp).Row).Value
For i = UBound(arr, 1) To 2 Step -1
If UCase(arr(i, 1)) = UCase("Total") Then
For j = 4 To 100
For k = 2 To UBound(arr, 2)
If UCase(arr(1, k)) = UCase(Cells(4, j)) Then
Sheets("sheet5").Cells(10, j).Value = arr(i, k)
End If
Next k
Next j
Exit For
End If
Next i
End With

 

[snow25]

Dear bạn,

Mình thấy đoạn code trc đó bạn gửi dễ hiểu hơn đoạn này. Nhưng số cột k chỉ giới hạn ("b3:m") mà nó còn nh hơn nữa như dưới mình khai báo. Khi đó code chạy khá chậm bạn ạ. Với đoạn code bạn gửi bên trên mình cũng đã thử nhưng chạy vẫn hơi chậm khi số cột tăng lên nh.

Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:ba" & .Range("b" & Rows.Count).End(xlUp).Row).Value
For i = UBound(arr, 1) To 2 Step -1
If UCase(arr(i, 1)) = UCase("Total") Then
For j = 4 To 100
For k = 2 To UBound(arr, 2)
If UCase(arr(1, k)) = UCase(Cells(4, j)) Then
Sheets("sheet5").Cells(10, j).Value = arr(i, k)
End If
Next k
Next j
Exit For
End If
Next i
End With

đây bạn xem code này

Sub chuyen()
Application.ScreenUpdating = False
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long, c As Long
Dim dk As String, dks As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet4")
arr = .Range("b3:n" & .Range("b" & Rows.Count).End(xlUp).Row).Value
a = Sheets("sheet5").Range("c" & Rows.Count).End(xlUp).Row
b = Sheets("sheet5").Cells(4, Columns.Count).End(xlToLeft).Column
c = UBound(arr, 1)
    For i = 2 To UBound(arr, 2)
     dk = arr(1, i)
       If dic.exists(dk) = 0 Then
          dic.Item(dk) = Array(arr(c, i))
       End If
    Next i
    For j = 4 To b
        dks = Sheets("sheet5").Cells(4, j).Value
       If dic.exists(dks) Then
          Sheets("sheet5").Cells(a, j).Value = dic.Item(dks)(0)
       End If
    Next j
End With
Application.ScreenUpdating = True
End Sub

 

[hadoan-pap]

đây bạn xem code này

Sub chuyen()
Application.ScreenUpdating = False
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long, c As Long
Dim dk As String, dks As String
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("sheet4")
arr = .Range("b3:n" & .Range("b" & Rows.Count).End(xlUp).Row).Value
a = Sheets("sheet5").Range("c" & Rows.Count).End(xlUp).Row
b = Sheets("sheet5").Cells(4, Columns.Count).End(xlToLeft).Column
c = UBound(arr, 1)
    For i = 2 To UBound(arr, 2)
     dk = arr(1, i)
       If dic.exists(dk) = 0 Then
          dic.Item(dk) = Array(arr(c, i))
       End If
    Next i
    For j = 4 To b
        dks = Sheets("sheet5").Cells(4, j).Value
       If dic.exists(dks) Then
          Sheets("sheet5").Cells(a, j).Value = dic.Item(dks)(0)
       End If
    Next j
End With
Application.ScreenUpdating = True
End Sub

Dear Snow,

Cảm ơn bạn nhé, nhưng that sự đoạn code này hơi khó hiểu và nó lại k áp dung đc vào bài toán của mình.

Mình muốn tham chiếu ở sheet4, nó phải bắt buộc check dc dòng có chữ " Total " thì mới bắt đầu tham chiếu data sang sheet5.

Đoạn code như bên dưới mình thấy chạy chuẩn rồi nhưng bị chậm do biến j chạy hơi dài và mảng khai báo ban đầu cũng hơi rộng.

Bạn có cách nào optimize dc đoạn code bên dưới k ? Đoạn này mình thấy áp dung chuẩn .

Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long, k As Long
With Sheets("sheet4")
arr = .Range("b3:ab" & .Range("b" & Rows.Count).End(xlUp).Row).Value
For i = UBound(arr, 1) To 2 Step -1
If UCase(arr(i, 1)) = UCase("Total") Then
For j = 4 To 20
For k = 2 To UBound(arr, 2)
If UCase(arr(1, k)) = UCase(Cells(4, j)) Then
Sheets("sheet5").Cells(10, j).Value = arr(i, k)
End If
Next k
Next j
Exit For
End If
Next i
End With