Copying multiple columns into one column - vba excel

 Sub MultyCol_to_OneColl ()

Dim arr() As Variant

Dim rng As Range

Dim x As Long

Application.ScreenUpdating = False

arr = Sheets("Sheet1").Range("A2:C100").Value

 For x = LBound(arr, 2) To UBound(arr, 2)

 With Sheets("Sheet1")

Set rng = .Cells(.Rows.Count, 4).End(xlUp).Offset(1)

 rng.Resize(UBound(arr, 1)).Value = Application.Index(arr, , x)

 Set rng = Nothing

End With

Next x

Erase arr

Application.ScreenUpdating = True

 End Sub

Sub MultyCol_to_One_Transpose()

Dim i As Integer

Dim rng As Range

Set rng = Sheet1.Range("C2").CurrentRegion

 For i = 1 To rng.Count

Sheet1.Cells(1 + i, 4) = rng(i)

Next i

End Sub

Sub MultyCol_to_OneColl_transpose()

Dim arr() As Variant

Dim rng As Range

Dim x As Long

Application.ScreenUpdating = False

arr = Sheets("Sheet1").Range("A2:C100").Value

 For x = LBound(arr, 2) To UBound(arr, 2)

 With Sheets("Sheet1")

Set rng = .Cells(.Rows.Count, 4).End(xlUp).Offset(1)

 rng.Resize(UBound(arr, 1)).Value = Application.Index(arr, , x)

 Set rng = Nothing

End With

Next x

Erase arr

Application.ScreenUpdating = True

With Worksheets("sheet1")

.Range(Range("d2"), Range("d2").End(xlDown)).Copy

.Range("e2").PasteSpecial Transpose:=True

.Range(Range("d2"), Range("d2").End(xlDown)).Value = ""

End With

 End Sub

COPY PASTE MULTY FORMAT - EXCEL VBA

 Copy dari area range tertentu dan dipastekan di active cell

Ada beberapa mode paste yang dapat digunakan sesuai keperluannya yaitu diantaranya :

‘paste tema termasuk interior , jenis dan ukuran font

 Simpan .PasteSpecial Paste:=xlPasteAllUsingSourceTheme

‘paste transpose

Simpan .PasteSpecial Transpose:=True

 ‘paste tanpa rumus

Simpan .PasteSpecial Paste:=xlPasteValues

‘paste rumus

Simpan .PasteSpecial Paste:=xlPasteFormulas

‘paste value dan interior

Simpan .PasteSpecial Paste:=xlPasteAll

Contoh1 :

Sub test_copy1 ()

 Set Salin = Range("B2:B13")

 Set Simpan = ActiveCell

 Salin.Copy

Simpan .PasteSpecial Transpose:=True

end sub

Contoh2 :

Sub test_copy1 ()

 Set Salin = sheets("hasil"). Range("g3:g32")

 Set Simpan = ActiveCell

 Salin.Copy

Simpan.PasteSpecial Paste:=xlPasteValues

End Sub

Demikian selamat mencoba !!

Membuat Rekap Multy sheet

Function pilihcopy() As Integer

 pilihcopy = 0

     If lstSheets.ListCount > 0 Then

         For k = 0 To lstSheets.ListCount - 1

    If lstSheets.Selected(k) Then

        pilihcopy = pilihcopy + 1

        End If

        Next

        End If

        End Function

Private Sub CommandButton1_Click()

    Dim Satukandata As Worksheet

    Dim dataCopyl      As Range

    Dim Sheets_baru As String

     Sheets_baru = Me.Nama_sheet_baru

If Sheets_baru = "" Then

        MsgBox "Ketik nama sheet baru"

        Me.Nama_sheet_baru.SetFocus

        Exit Sub

    End If

    On Error Resume Next

 Set Satukandata = Sheets.Add(after:=Sheets(5))

    Satukandata.Name = Sheets_baru

    If Err = 1004 Then

        MsgBox Err.Description

        Application.DisplayAlerts = False

        ActiveSheet.Delete

        Application.DisplayAlerts = True

        Exit Sub

    End If

    On Error GoTo 0

    Set dataCopyl = Satukandata.Cells(1, 1)

    For k = 0 To lstSheets.ListCount - 1

        If lstSheets.Selected(k) Then

            Sheets(lstSheets.List(k)).Select

            Sheets(lstSheets.List(k)).Cells.SpecialCells(xlLastCell).Select

            Range(Selection, Cells(1, 1)).Select

            Selection.Copy

            Satukandata.Select

            dataCopyl.Select

            Satukandata.Paste

            Selection.PasteSpecial Paste:=xlPasteValues

            Selection.SpecialCells(xlLastCell).Select

            Set dataCopyl = Satukandata.Cells(ActiveCell.Row + 1, 1)

    End If

    Next

    Unload Me

End Sub

Private Sub CommandButton2_Click()

Dim Cnt As Long, i As Long

Cnt = Sheets.Count

Application.DisplayAlerts = False

     For i = Cnt - 0 To 6 Step -1

          Sheets(i).Delete

     Next i

Application.DisplayAlerts = True

End Sub

Private Sub UserForm_Initialize()

    For k = 1 To Sheets.Count

        lstSheets.AddItem Sheets(k).Name

    Next

   End Sub

Baca juga :

-  Input Data dan Foto

-  Input Data Sederhana

-  Edit Data Sederhana

-  Input Pilihan Ke Tabel Kolom

-  Input Pilihan Ke Tabel Baris

-  Input Menolak Data Ganda

-  Input Transpose


-  Kosa Kata Dasar dalam VBA

- Rumus Menjadi Kode VBA


DAPATKAN PAKET BELAJAR EBOOK VBA

- Paket Belajar Ebook pdf full VBA

Copy Paste Transpose

Tranpose array
Salah satu model copy paste yakni copy paste data baris menjadi data kolom demikian pula sebaliknya sesuai funsi bawaan excel yang dikenal dengan Copy Transpose

Namun kali ini bagaimana mengaplikasikan fungsi tersebut ke sebuah macro atau Vba
Caranya juga cukup mudah kita hanya perlu sebuah modul yang akan kita panggil dengan sebuah modul

Buatlah table seperti gambar diatas kemudian buatlah sebuah modul dan pastekan kode berikut pada modul

Namun sebelumnya sesuaikan dengan nama sheet dimana dicopy dan dimana mau dipaste
Demikian pula cell atau area yang akan menjadi target harus disesuaikan dikode pada modul
Sub Tranpose()
Worksheets("data1").Range("A2:b20").Copy
Worksheets("data1").Range("d2").PasteSpecial Transpose:=True
End Sub

Selesai
semoga bermanfaat

Sampel file dapat didownload di link berikut

Rekap Multy file

                Rekap Multy file

Kadang Kita membutuhkan data yang disimpan pada sebuah file d idokumen atau di sebuah folder yang berbeda namun kita ingin data yang dimaksud dapat terkumpul menjadi satu dalam bnentuk rekap halaman  di sheet active

Caranya cukup kita membuat sebuah modul dan pastekan kode berikut yang selanjutnya akan dipanggil dengan  sebuah tombol
Kode lengkapnya adalah :

Sub kumpulkan()
FileTerpilih = Application.GetOpenFilename _
("XLSX File (*.xlsx),*.xlsx", Title:="Open file", MultiSelect:=True)
If VarType(FileTerpilih) = vbBoolean Then
Exit Sub
End If
NamaFileUtama = ActiveWorkbook.Name
JumlahFile = UBound(FileTerpilih)
Application.DisplayAlerts = False
For i = 1 To JumlahFile
Workbooks.Open FileTerpilih(i)
With ActiveWorkbook.Worksheets("data1")
BarisTerakhirFilePilihan = .Cells(.Rows.Count, 1).End(xlUp).Row
BarisTerakhirFileUtama = Workbooks(NamaFileUtama).Worksheets("Sheet1") _
.Cells(Workbooks(NamaFileUtama).Worksheets("sheet1").Rows.Count, 1).End(xlUp).Row
   .Range("A6:M" & BarisTerakhirFilePilihan).Copy _
Destination:=Workbooks(NamaFileUtama).Worksheets("Sheet1").Range("A" & BarisTerakhirFileUtama + 1)
        End With
         ActiveWorkbook.Close
Next i
Application.DisplayAlerts = True
End Sub

Perlu diketahui :
Mengacu pada kode diatas syarat utama adalah active adalah
Sheet1 sebagai tempat penyimpanan atau dikumpulkan kemudian 
sheet yang akan di impor adalah sheet yang bernama  DATA1
Semua sheets disetiap file dimana saja atau di folder mana pun

Untuk reset atau akan mengulang kembali pastekan kode ini juga pada sebuah modul :

Sub RESET()
Sheets("Sheet1").Range("a3:m1000").Clear
End Sub

Selesai
Semoga bermanfaat
Sampel file dapat di unduh pada link dibawah ini



 Rekap Multy File 

Copy Paste Special - VBA EXCEL

Copy paste special Format cell

Copy Color special format adalah menggunakan Kode VBA maksud Copy paste semua bentuk format akan dicopy  baik interior , value dan format cellnya jadi akan menghasil copy yang sama persis dengan aslinya

Cara  juga hanya perlu membuat sebuah modul
Pastekan kode berikut :

Sub Copy_interior()
    Range("B2:B13").Select
    Application.CutCopyMode = False
    Selection.copy
    Range("E2").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
ThisWorkbook.Worksheets("Sheet1").Range("E:E").EntireColumn.AutoFit
        End Sub

Sub Reset()
With ActiveSheet
ActiveSheet.Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
End With
End Sub

Sub CopyFormat_last_Row()

Sheets("Sheet1").Range("a2:d10").Copy

Sheets("Sheet2").Cells(Cells.Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial Paste:=xlPasteAllUsingSourceTheme

End Sub

Berikut pilihan jenis copy special :

PasteSpecial Paste:=xlPasteAllUsingSourceTheme

          Hasil copy sama persis dgn aslinya

PasteSpecial Transpose:=True

         Hasil copy transpose

PasteSpecial Paste:=xlPasteValues

         Hasil copy Value

PasteSpecial Paste:=xlPasteFormulas

        Hasil copy Rumusnya tetap

PasteSpecial Paste:=xlPasteAll

       Hasil copy sama persis dgn aslinya termasuk rumus tetap ada

Selesai
Mari rajin mencoba ,Semakin rajin mencoba maka semakin banyak pengalaman yang kita akan dapat
Semoga bermanfaat

Copy color Only

       Copy color Only

Copy Color Only adalah menggunakan Kode VBA maksud Copy paste namun hanya warna cell interior saja yang akan dicopy
Adapun isi atau value tidak ikut di copy
Cara  juga hanya perlu membuat sebuah modul
Pastekan kode berikut :

Sub copywarna ()
    Dim cell As Range
    For Each cell In Range("g2:g200")
         Range("a" & cell.Row).Interior.Color = cell.Interior.Color
    Next cell
End Sub

Selesai
Silahkan dicoba dilembar kerja excel anda
Semakin rajin mencoba maka semakin banyak pengalaman yang kita akan dapat
Semoga bermanfaat

Copy UserForm ke Dokumen