Print or Copy function

[milesy]

HI Guys

i struggling here so looking for help

I have a spreadsheet called ORDER STATUS, that contains data from A2 though to AH10000

What i am trying to achieve is to simply print all Rows that contain a certain order number (Column A) and then print only the columns

A, B, C
E
FG
I
K (and only if K = In progress)
M

I can do this using filters and hiding columns but im looking for some VB code to simply enter the Value of A (say 13270) and it will print the columns as shown above

Anyone have a solution to do this?

thanks in advance

Adrian

 

[HaHoBe]

Hi Adrian,

one way to solve this. I added a new sheet and put all the code behind that sheet. Action is limited to Range("A1"), you can change that as needed, chnage can be triggered by directlly entering or by using Data/Validation:

Private Sub Worksheet_Change(ByVal Target As Range)
'https://www.mrexcel.com/board/threads/print-or-copy-function.1219445/

Dim wsOrder       As Worksheet
Dim wsNew         As Worksheet
Dim lngC          As Long
Dim rngFound      As Range
Dim rngArea       As Range
Dim rngCell       As Range

On Error GoTo err_here

If Target.Count > 1 Then Exit Sub
If Target.Address = "$A$1" Then
  Set wsOrder = Sheets("ORDER STATUS")
  With wsOrder
    If WorksheetFunction.CountIf(.Columns(1), Target.Value) > 0 Then
      If .AutoFilterMode Then .Range("A1").AutoFilter
      .Range("A1").CurrentRegion.AutoFilter 1, Target.Value
      .Range("A1").CurrentRegion.AutoFilter 11, "In progress"
      Set rngFound = .Range("A1:M" & .Range("A" & .Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
      If rngFound.Areas.Count = 1 And rngFound.Rows.Count = 1 Then
        MsgBox "No orders for number '" & Target.Value & "' found", vbInformation, "No further action"
        GoTo end_here
      End If
      Application.ScreenUpdating = False
      Set wsNew = Worksheets.Add(after:=Worksheets(Worksheets.Count))
      wsNew.Name = "For_" & Target.Value & Format(Now, "_yymmdd_hhnnss")
      For Each rngArea In rngFound.Areas
        wsNew.Range("A" & wsNew.Rows.Count).End(xlUp).Offset(1, 0).Resize(rngArea.Rows.Count, rngArea.Columns.Count).Value = rngArea.Value
      Next rngArea
      For lngC = wsNew.UsedRange.Columns.Count To 1 Step -1
          Select Case lngC
            Case 1, 2, 3, 5, 6, 7, 9, 11, 13
              'do nothing, this is the data we want
            Case Else
              wsNew.UsedRange.Columns(lngC).Delete
          End Select
      Next lngC
      Application.ScreenUpdating = True
    Else
      MsgBox "No orders for number '" & Target.Value & "' found", vbInformation, "No further action"
    End If
    .Range("A1").AutoFilter
  End With
End If

end_here:
Set wsNew = Nothing
Set rngFound = Nothing
Set wsOrder = Nothing
Exit Sub

err_here:
  MsgBox "An error occurred, please find error number and description in the immediate window.", vbInformation, "Sorry for inconvenience"
  Debug.Print "Date/Time: " & Now & vbCrLf & "Error number: " & Err.Number & vbCrLf & _
      "Description: " & Err.Description & vbCrLf & "Error Source: " & Err.Source
  Resume end_here
End Sub

You can change the code to copy over into a template. With the code supplied you willl be left with an empty first row which could be deleted. Or you enter a text into the new sheet in Column A and add the cells directly below.

Cioao,
Holger

 

[HaHoBe]

Hi Adrian,

instead of working though the area with the filtered data you could copy at once like

Private Sub Worksheet_Change(ByVal Target As Range)
'https://www.mrexcel.com/board/threads/print-or-copy-function.1219445/

Dim wsOrder       As Worksheet
Dim wsNew         As Worksheet
Dim lngC          As Long
Dim rngFound      As Range

On Error GoTo err_here

If Target.Count > 1 Then Exit Sub
If Target.Address = "$A$1" Then
  Set wsOrder = Sheets("ORDER STATUS")
  With wsOrder
    If WorksheetFunction.CountIf(.Columns(1), Target.Value) > 0 Then
      If .AutoFilterMode Then .Range("A1").AutoFilter
      .Range("A1").CurrentRegion.AutoFilter 1, Target.Value
      .Range("A1").CurrentRegion.AutoFilter 11, "In progress"
      Set rngFound = .Range("A1:M" & .Range("A" & .Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
      If rngFound.Areas.Count = 1 And rngFound.Rows.Count = 1 Then
        MsgBox "No orders for number '" & Target.Value & "' found", vbInformation, "No further action"
        GoTo end_here
      End If
      Application.ScreenUpdating = False
      Set wsNew = Worksheets.Add(after:=Worksheets(Worksheets.Count))
      wsNew.Name = "For_" & Target.Value & Format(Now, "_yymmdd_hhnnss")
      rngFound.Copy wsNew.Range("A1")
      For lngC = wsNew.UsedRange.Columns.Count To 1 Step -1
          Select Case lngC
            Case 1, 2, 3, 5, 6, 7, 9, 11, 13
              'do nothing, this is the data we want
            Case Else
              wsNew.UsedRange.Columns(lngC).Delete
          End Select
      Next lngC
      Application.ScreenUpdating = True
    Else
      MsgBox "No orders for number '" & Target.Value & "' found", vbInformation, "No further action"
    End If
    .Range("A1").AutoFilter
  End With
End If

end_here:
Set wsNew = Nothing
Set rngFound = Nothing
Set wsOrder = Nothing
Exit Sub

err_here:
  MsgBox "An error occurred, please find error number and description in the immediate window.", vbInformation, "Sorry for inconvenience"
  Debug.Print "Date/Time: " & Now & vbCrLf & "Error number: " & Err.Number & vbCrLf & _
      "Description: " & Err.Description & vbCrLf & "Error Source: " & Err.Source
  Resume end_here
End Sub

Ciao,
Holger