Convert multiple contiguous columns as one single column maintaining their(rows and columns) order using VBA

   

Dim wb As Workbook

 Set wb = ActiveWorkbook

 Dim wf As Worksheet


With wb
    For Each oSheet In .Sheets

        If oSheet.Name = "verticalmm" Then
            oSheet.Delete
            
          
            
            
            
            

        End If
Next oSheet
    Set wf = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    wf.Name = "verticalmm"
    End With
    
    
' wb.Close savechanges:=True
   
   
    Dim Range1 As Range, Range2 As Range, Rng As Range
    Dim rowIndex As Integer
    we.Select
    
    Range("B2").Select
    If ActiveCell.Offset(1, 0).Value <> "" Then
    
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Else
    Exit Sub
    End If
    
   Set Range1 = Application.Selection
   'Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
     'Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
     Set Range2 = wf.Range("A1")
     'we.Select
     For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
wf.Select

Dim last_row As Long

    last_row = Cells(Rows.Count, 1).End(xlUp).Row
    'MsgBox (last_row)
    
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "0"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A1:A2").Select
    Selection.AutoFill Destination:=Range("A1:A" & last_row)
    
   
   wb.Close savechanges:=True

 

 

Source:https://www.extendoffice.com/documents/excel/1172-excel-transpose-multiple-columns-into-one-column.html

Printing filtered data and stopping printing blank pages and fitting all columns in one page using vba

 Sub justprint()

Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If









'let us first delete anysheet containing name like Canada and create sheets named as Canada

 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
Dim wks, newsheet As Worksheet


For Each wks In Application.Worksheets
        If wks.name = "Canada" Then wks.Delete
    Next



 Dim cntsheets As Long
 
     cntsheets = Application.Sheets.Count
    Set newsheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    newsheet.name = "Canada"

   

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet
'creating the directory for pdf files

Dim output_file As String, ws_count, i As Integer
Dim path, folder As String
path = "C:\Users\allso\Desktop\excel_to_pdf_2"
folder = dir(path, vbDirectory)
If folder = vbNullString Then

       
                VBA.FileSystem.MkDir (path)
          

    Else

    

    End If
    
Sheets("Sheet1").Select

Dim mynetwork As Object


Dim dataforfilter As String
Dim strtime As String
'set current default printer
Set mynetwork = CreateObject("WScript.network")
mynetwork.setdefaultprinter "Adobe PDF"
Dim objAccess As Object
Set objAccess = CreateObject("Access.Application")
Dim prtLoop As Object
'get current default printer
Set prtLoop = objAccess.Printer
'now we can access the printquality supported by the default printer by using prtloop.printquality

dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
ActiveSheet.Range(dataforfilter).AutoFilter Field:=2, Criteria1:="Canada", Operator:=xlFilterValues
'ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues
'sort the filtered range by the column gross sales
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
Range(dataforfilter).Sort key1:=[h2], Order1:=xlDescending, Header:=xlYes
ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Copy

Sheets("Canada").Select
'Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        
'autofitting the columns
ActiveSheet.Cells.Columns.AutoFit
'removing the borders
'changing the font
 With ActiveSheet.Cells.Font
 
        .name = "Georgia Pro"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

ActiveSheet.Cells.Borders.LineStyle = xlLineStyleNone

'now saving the sheet as pdf


If Format(CDate(Now), "am/pm") = "am" Then
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " AM"
Else
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " PM"
End If

output_file = path & "\" & Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5) & "." & ActiveSheet.name & "." & strtime & ".pdf"

'setting the page setup

'ActiveSheet.PageSetup.CenterHeader = "&B&14" & "Financial Data for " & uniquedatafinal(length) & ""

'&""Courier New""

'determine it is am or pm

If Format(CDate(Now), "am/pm") = "am" Then


ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & "Canada" & " on " & "&D" & "," & "&T" & " AM"
Else
ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & "Canada" & " on " & "&D" & "," & "&T" & " PM"

End If

'this is for setting the right footer of print which will print as Page (number of current page) of Total Pages
ActiveSheet.PageSetup.RightFooter = "&B&10&""Arial Narrow""&K00B0F0" & "Page &P of &N"

'change activeprinter to a choice of mine

'to set printarea manually we have to calculate the printarea using this lastrow
Dim lastrow As Long

lastrow = Application.WorksheetFunction.Subtotal(3, Range("P:P"))

'this commented out section works best with portrait printing

With ActiveSheet.PageSetup
.CenterHorizontally = True
'.CenterVertically = True
.BottomMargin = 50
.TopMargin = 50
.RightMargin = 10
.LeftMargin = 10
'.Zoom = 50
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.Orientation = xlPortrait
.PrintQuality = prtLoop.PrintQuality
.PrintArea = "A1:P" & lastrow

End With
'MsgBox (ActiveSheet.PageSetup.PrintArea.Address)
'ActiveSheet.PrintPreview
'this section works best for landscape printing
'With ersheet.PageSetup
''for setting portrait or landscape
'.Orientation = xlLandscape
''these next two line will fit all columns in one page
'.FitToPagesWide = 1
'.FitToPagesTall = 1
''this line is responsible for continuing one fixed row on several print pages ,it is similar as excel freeze pane
'.PrintTitleRows = ersheet.Rows(1).Address
'End With
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False
    
    
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If



If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

End Sub

Source:https://stackoverflow.com/questions/25741049/how-to-set-fit-all-columns-on-one-page-in-print-tab

Source:https://stackoverflow.com/questions/17285897/row-count-on-the-filtered-data

Select and open an excel file using filedialog vba

 Dim wb As Workbook
  Dim wc, wd, oSheet As Worksheet
 
 ' Create and set the file dialog object.
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Filters.Clear
        .Title = "Select an Excel File"
        .Filters.Add "Excel Files", "*.xlsx?", 1
        .AllowMultiSelect = False
        .InitialFileName = "C:\Users\allso\Desktop\test"
        Dim sFile As String
    
        If .Show = True Then
            sFile = .SelectedItems(1)
        End If
    End With
    
    If sFile <> "" Then
       Set wb = Workbooks.Open(sFile)   ' Open the Excel file.
    End If

 'save and close the file

   wb.Close savechanges:=True

Freeze the top row using vba

 
    Rows("1:1").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

Create a new sheet at the end of all sheet with a name stored in a variable using vba

  

dim wd as worksheet

dim newsheetname as sring

newsheetname="NewSheet"

 

Set wd = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    wd.Name = newsheetname
    End With

Remove duplcate values from an array using VBA

 arr1 = Range(Range("C13"), Range("C13").End(xlDown)).Value2
arr2 = Range(Range("E13"), Range("E13").End(xlDown)).Value2
'arr2 = ws.Range("E13:E25").Value2
    
arr3 = Split(Join(Application.Transpose(arr1), ",") & "," & Join(Application.Transpose(arr2), ","), ",")
'Debug.Print Join(arr3, ",")

Dim poArrNoDup()
Dim duparrindex As Integer

    duparrindex = -1
    For i = LBound(arr3) To UBound(arr3)
        dupBool = False

        For j = LBound(arr3) To i
            If arr3(i) = arr3(j) And Not i = j Then
                dupBool = True
            End If
        Next j

        If dupBool = False Then
            duparrindex = duparrindex + 1
            ReDim Preserve poArrNoDup(duparrindex)
            poArrNoDup(duparrindex) = arr3(i)
        End If
    Next i

Combine two arrays in one array using vba

arr1 = Range(Range("C13"), Range("C13").End(xlDown)).Value2
arr2 = Range(Range("E13"), Range("E13").End(xlDown)).Value2
'arr2 = ws.Range("E13:E25").Value2
    
arr3 = Split(Join(Application.Transpose(arr1), ",") & "," & Join(Application.Transpose(arr2), ","), ",")
'Debug.Print Join(arr3, ",")

Delete all rows after the current row using vba

 Rows(ActiveCell.Offset(1, 0).Row & ":" & Rows.Count).Delete