vba copy columns from two sheets?

[muhmath2002]

hi all
i need vba code to solve this problem:
i have excel file with sheet1 and sheet2 contains columns values from a1 cell
we need new sheet from two sheets excel file to put columns values inside
like column1 from sheet1 then column1 from sheet2 then column2 from sheet1 then column2 from sheet2....
regards

 

[JLGWhiz]

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets.Add(After:=sh2)
lc1 = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
lc2 = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
    If lc1 > lc2 Then
        lc = lc1
    Else
        lc = lc2
    End If
    For i = 1 To lc
        If Application.CountA(sh1.Columns(i)) > 0 Then
            Intersect(sh1.Columns(i), sh1.UsedRange).Copy
            sh3.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValuesAndNumberFormats
        End If
        If Application.CountA(sh2.Columns(i)) > 0 Then
            Intersect(sh2.Columns(i), sh2.UsedRange).Copy
            sh3.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next
End Sub

 

[muhmath2002]

JLGWhiz​

thanks man for fantastic code to put values inside , i test it and very fast
sorry i need to put values beside (Horizontaly)
please modify vba code
regards

 

[VBasic2008]

Create Summary Worksheet

Option Explicit

Sub createReportWorksheet()
    
    ' Define constants.
    Const srcFirst As String = "A1"
    Const tgtName As String = "Report"
    Const tgtFirst As String = "A1"
    Dim srcNames As Variant
    srcNames = Array("Sheet1", "Sheet2") ' add more...
    
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    
    ' Delete Target Worksheet if it exists.
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Sheets(tgtName).Delete
    Application.DisplayAlerts = True
    On Error Resume Next
    
    ' Define Target Worksheet.
    Dim tgt As Worksheet
    ' Last position.
    Set tgt = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    ' First position.
    'Set tgt = wb.Worksheets.Add(Before:=wb.Sheets(1))
    tgt.Name = tgtName
    
    ' Define Target First Cell Range.
    Dim cel As Range
    Set cel = tgt.Range(tgtFirst)
    
    ' Prepare to write values from Source Worksheets to Target Worksheet.
    Dim rng As Range ' Current Source Range
    Dim n As Long    ' Worksheet Names Array Elements Counter.
    
    ' Write values from Source Worksheets to Target Worksheet.
    For n = LBound(srcNames) To UBound(srcNames)
        ' Define Current Source Range.
        On Error Resume Next
        ' Either...
        Set rng = wb.Worksheets(srcNames(n)) _
                    .Range(srcFirst).CurrentRegion
        ' ...or:
        'Set rng = wb.Worksheets(srcNames(n)).UsedRange
        ' ...or: other ways, most notable using the 'Find' method.
        On Error GoTo 0
        ' Check if Current Worksheet was found.
        If Not rng Is Nothing Then
            ' Either... (more efficient, but only values)
            ' Write values from Current Source Worksheet to Target Worksheet.
            cel.Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
            '...or: (values, formulas and formats)
            'rng.Copy cel
            '...or: (What ever you choose. Can be applied multiple times.)
            'rng.Copy
            'cel.PasteSpecial ' and choose the optional parameter.
            'Application.CutCopyMode = False
            
            ' Define Next First Cell Range.
            ' Either:
            ' Horizontally:
            Set cel = cel.Offset(, rng.Columns.Count)
            ' ...or:
            ' Vertically:
            'Set cel = cel.Offset(rng.Rows.Count)
        End If
    Next n
     
    ' Save workbook.
    'wb.Save
     
    ' Inform user.
    MsgBox "Report sheet created.", vbInformation, "Success"

End Sub

 

[JLGWhiz]

This copies and pastes horizontally.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets.Add(After:=sh2)
lc1 = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
lc2 = sh2.Cells(1, Columns.Count).End(xlToLeft).Column
    If lc1 > lc2 Then
        lc = lc1
    Else
        lc = lc2
    End If
    For i = 1 To lc
        If Application.CountA(sh1.Columns(i)) > 0 Then
            Intersect(sh1.Columns(i), sh1.UsedRange).Copy
            sh3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
        If Application.CountA(sh2.Columns(i)) > 0 Then
            Intersect(sh2.Columns(i), sh2.UsedRange).Copy
            sh3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next
End Sub

 

[JLGWhiz]

@VBasic2008 - are you sure you posted to the correct thread?

 

[muhmath2002]

VBasic2008​

thanks man you must correct vba code for correct output in new sheet , i test it

JLGWhiz​

big thanks and god bless you
the problem now solved

 

[VBasic2008]

@VBasic2008 - are you sure you posted to the correct thread?

I've tried your code and saw what I missed. It's not my day today. Thanks for the reply.

 

[JLGWhiz]

JLGWhiz​

big thanks and god bless you
the problem now solved

You're welcome,
regards, JLG