Pada dasarnya, saya memiliki satu set sel yang akan selalu memiliki font hijau (terletak di rentang Current_Scenerio). Saya ingin menyalin dan menempelkan nilai ke rentang baru (Thesis_A).

Dengan kode saat ini dapat memilih salin nilai berdasarkan saat sel diformat hijau. Tapi saya mengalami kesulitan menempelkan ini ke rentang baru dengan pemosisian relatif.

Saya perlu menjaga rentang dinamis sehingga saya tidak dapat menggunakan offset dengan penentuan posisi absolut, semuanya harus relatif karena rentangnya akan diubah.

Saya bertanya-tanya apakah ada cara untuk mengembalikan posisi sel relatif ke yang lain. Misalnya, saya telah menamai sel Current_Scenerio_Start, jika saya bisa mendapatkan posisi sel ini relatif terhadap Current_Scenerio_Start (katakanlah 5 baris ke bawah dan 3 kolom melintang), saya kemudian bisa menempelkan nilai ketika font sel berwarna hijau ke dalam rentang baru relatif terhadap posisi awal lainnya.

Sayangnya, saya tidak tahu bagaimana melakukannya/jika itu mungkin.

Option Explicit

Sub PasteThesisA()

Dim CurrentScenrioRange As Range
Dim ThesisARange As Range
Dim Cell As Range

Set CurrentScenrioRange = Scenerios.Range("Current_Scenerio:Current_Scenerio_End")
Set ThesisARange = Scenerios.Range("Thesis_A:Thesis_A_End")


For Each Cell In CurrentScenrioRange
    Cell.Select
    If Cell.Font.Color = RGB(0, 176, 80) Then
        With Scenerios
            .Range(ThesisARange).Value = .Range(CurrentScenrioRange).Value
        End With
    End If
Next
End Sub

Saat ini saya hanya mendapatkan kesalahan karena saya tahu bahwa saya bukan rentang yang ingin saya tempel dengan benar

0
bigalbunyan 9 Agustus 2019, 22:49

1 menjawab

Jawaban Terbaik

Maaf, saat ini saya tidak dapat menguji salah satu dari saran ini. Mereka sepertinya akan berhasil (di kepala saya), tetapi mungkin saya melewatkan sesuatu.

Jika kedua rentang berbentuk persegi panjang/persegi (yaitu setiap baris memiliki jumlah kolom yang sama dan setiap kolom memiliki jumlah baris yang sama), maka mungkin menukar loop For Each dengan dua loop For (satu untuk baris, satu untuk kolom). Sesuatu seperti:

Option Explicit

Sub PasteThesisA()

    Dim CurrentScenrioRange As Range
    Dim ThesisARange As Range

    Dim greenFontColour As Long
    greenFontColour = RGB(0, 176, 80)

    Set CurrentScenrioRange = Scenerios.Range("Current_Scenerio:Current_Scenerio_End")
    Set ThesisARange = Scenerios.Range("Thesis_A:Thesis_A_End")

    Dim rowIndex As Long
    For rowIndex = 1 To CurrentScenrioRange.Rows.Count
        Dim columnIndex As Long
        For columnIndex = 1 To CurrentScenrioRange.Columns.Count
            If CurrentScenrioRange(rowIndex, columnIndex).Font.Color = greenFontColour Then
                ThesisARange(rowIndex, columnIndex).Value = CurrentScenrioRange(rowIndex, columnIndex).Value
            End If
        Next columnIndex
    Next rowIndex
End Sub

Kalau tidak (jika bukan persegi panjang/persegi), mungkin Anda bisa mencoba menghitung indeks baris dan kolom relatif:

Option Explicit

Sub PasteThesisA()

    Dim CurrentScenrioRange As Range
    Dim ThesisARange As Range

    Set CurrentScenrioRange = Scenerios.Range("Current_Scenerio:Current_Scenerio_End")
    Set ThesisARange = Scenerios.Range("Thesis_A:Thesis_A_End")

    Dim greenFontColour As Long
    greenFontColour = RGB(0, 176, 80)

    Dim Cell As Range
    For Each Cell In CurrentScenrioRange

        Dim relativeRowIndex As Long
        relativeRowIndex = Cell.Row - CurrentScenrioRange.Rows(1).Row + 1 ' Might be better to second figure in a variable, instead of re-reading.

        Dim relativeColumnIndex As Long
        relativeColumnIndex = Cell.Column - CurrentScenrioRange.Columns(1).Column + 1 ' Might be better to second figure in a variable, instead of re-reading.

        If Cell.Font.Color = greenFontColour Then
            ThesisARange(relativeRowIndex, relativeColumnIndex).Value = Cell.Value
        End If
    Next
End Sub
1
chillin 9 Agustus 2019, 20:19