Menyederhanakan Macro

  1. 8 bulan yang lalu

    Dear master-master disini

    tolong dibantu menyederhanakan code ini :

    Sub CopyFileUpload()
    
        Application.ScreenUpdating = False
        
        Range("A3:H1000").ClearContents
        
        'copySKSHHK
        SheetAngkutan.Activate
        Range("J2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        
        
        SheetUpload.Activate
        Range("A3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Application.CutCopyMode = False
        
        'copyIDBarcode
        SheetAngkutan.Activate
        Range("C2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        
        
        SheetUpload.Activate
        Range("B3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Application.CutCopyMode = False
        
        'copyJenis
        SheetAngkutan.Activate
        Range("F2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        
        
        SheetUpload.Activate
        Range("C3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Application.CutCopyMode = False
            
        'copyDPKB
        SheetAngkutan.Activate
        Range("J2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        
        
        SheetUpload.Activate
        Range("D3").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Application.CutCopyMode = False
            
        'CopyHeader
        
        SheetRekap.Activate
        Range("B3", Cells(Rows.Count, "B").End(xlUp).Offset(-1)).Select
        Selection.Copy
        
        SheetUpload.Activate
        Range("F3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("G3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("A3").Select
        
    End Sub

    terima kasih sebelumnya ;)

    @manweljs_ ...

    Untuk pertanyaan pertama, sepertinya ada korelasinya dengan pertanyaan kedua ya?! Anyway, jika kedua pertanyaan digabungkan ke dalam ke dalam prosedur yang sama, kurang lebih dapat disederhanakan menjadi seperti berikut:

    Sub CopyFileUpload()
    
        Application.ScreenUpdating = False
    
        SheetUpload.Cells.ClearContents
        With SheetAngkutan
            .Range( _
                .Range("C2", .Range("C2").End(xlDown)).Address & "," & _
                .Range("F2", .Range("F2").End(xlDown)).Address & "," & _
                .Range("J2", .Range("J2").End(xlDown)).Address).Copy
        End With
        SheetUpload.Range("B3").PasteSpecial Paste:=xlPasteValues
        SheetRekap.Range("B3", SheetRekap.Cells(SheetRekap.Rows.Count, "B").End(xlUp).Offset(-1)).Copy
        
        With SheetUpload
            .Select
            .Range("F3").PasteSpecial Paste:=xlPasteValues
            .Range("G3").PasteSpecial Paste:=xlPasteValues
            .Range("A3").Select
        End With
        
        Application.ScreenUpdating = True
        
    End Sub

    Demikian, semoga sesuai... ;)

  2. Di sunting 8 bulan yang lalu oleh manweljs_

    saya mencoba code ini

        Set a1 = SheetAngkutan.Range("C2", Selection.End(xlDown))
        Set a2 = SheetAngkutan.Range("F2", Selection.End(xlDown))
        Set a2 = SheetAngkutan.Range("J2", Selection.End(xlDown))
        Union(a1, a2, a3).Select
        Selection.Copy

    namun mengalami bug di Union(a1, a2, a3).Select

    mohon bantuannya di bagian mana yang salah. thanks before ;)

  3. Caton

    4 Mar 2018 Terverifikasi Indonesia + 12.523 Poin
    Di sunting 8 bulan yang lalu oleh Caton

    Mungkin karena variabel a3 merupakan Empty Object (Nothing). Coba periksa baris script sebelumnya, apakah variabel a3 telah ditetapkan nilai atau objeknya. Mungkin seharusnya:

    ...
    Set a3 = SheetAngkutan.Range("J2", Selection.End(xlDown))
    Union(a1, a2, a3).Select
    Selection.Copy
    ...

    Satu hal lagi, jika tujuannya ingin menyalin beberapa range terpisah, script tersebut di atas sepertinya tidak akan berhasil, karena saat script Union(a1, a2, a3).Select dieksekusi, VBA akan menggabungkan dengan cara me-resize range pada variabel A1 dan range pada variabel A2 kemudian dengan range pada variabel A3. Akibatnya, seluruh range pada variabel A1, A2 dan A3 akan menjadi satu range. Untuk mencapai tujuan tersebut, script di atas dapat disederhanakan menjadi:

    ...
    With SheetAngkutan
        .Select
        .Range( _
            .Range("C2", .Range("C2").End(xlDown)).Address & "," & _
            .Range("F2", .Range("F2").End(xlDown)).Address & "," & _
            .Range("J2", .Range("J2").End(xlDown)).Address).Copy
    End With
    ...

    Demikian...

  4. Caton

    4 Mar 2018 Terverifikasi Jawaban Terpilih Indonesia + 12.523 Poin
    Di sunting 8 bulan yang lalu oleh Caton

    @manweljs_ ...

    Untuk pertanyaan pertama, sepertinya ada korelasinya dengan pertanyaan kedua ya?! Anyway, jika kedua pertanyaan digabungkan ke dalam ke dalam prosedur yang sama, kurang lebih dapat disederhanakan menjadi seperti berikut:

    Sub CopyFileUpload()
    
        Application.ScreenUpdating = False
    
        SheetUpload.Cells.ClearContents
        With SheetAngkutan
            .Range( _
                .Range("C2", .Range("C2").End(xlDown)).Address & "," & _
                .Range("F2", .Range("F2").End(xlDown)).Address & "," & _
                .Range("J2", .Range("J2").End(xlDown)).Address).Copy
        End With
        SheetUpload.Range("B3").PasteSpecial Paste:=xlPasteValues
        SheetRekap.Range("B3", SheetRekap.Cells(SheetRekap.Rows.Count, "B").End(xlUp).Offset(-1)).Copy
        
        With SheetUpload
            .Select
            .Range("F3").PasteSpecial Paste:=xlPasteValues
            .Range("G3").PasteSpecial Paste:=xlPasteValues
            .Range("A3").Select
        End With
        
        Application.ScreenUpdating = True
        
    End Sub

    Demikian, semoga sesuai... ;)

  5. Dear mas @Caton

    as usual, it's works!!!

    saya cuma mengubah sedikit kodenya yaitu di SheetUpload ada header yang tidak perlu dihapus.

    terima kasih sekali lagi ya mas. Cheers!

  6. Caton

    4 Mar 2018 Terverifikasi Indonesia + 12.523 Poin

    Sama-sama mas @manweljs_ ... :)

 

atau Mendaftar untuk ikut berdiskusi!