Posting a Range

[darcus]

Hi

I hope you can help.

I have a range of cells on one sheet - this range can change depending upon contents.

So, For example, the entire range is between cells B19 and G31

I am thinking - if I copy this range to an Array then how do i tell the array that I don't want blank cells when I copy them into another sheet?

At the moment, this is how I am telling the system to save my invoice data to my excel sheet, and produce a PDF copy of the invoice and a delivery note from the information.

I desperately need to make this faster.

Sub SaveInvoice()  Dim src As Worksheet
  Dim dest As Worksheet
  Dim raw As Worksheet
  Dim rng As Range
  Dim i As Long
  Dim b As Long
  Dim rng_dest As Range
  Dim todaydate As Date
  Dim lnColumns As Long
  Set src = Sheets("Invoice")
  Set dest = Sheets("Invoice data")
  Set rng_dest = dest.Range("F:L")
  Set raw = Sheets("Raw")
  Set rng = raw.Range("A1:G13")
    Dim screenUpdateState As Boolean
    Dim statusBarState As Boolean
    Dim calcState As Boolean
    Dim eventsState As Boolean
    Dim displayPageBreakState As Boolean
    screenUpdateState = Application.ScreenUpdating
    statusBarState = Application.DisplayStatusBar
    calcState = Application.Calculation
    eventsState = Application.EnableEvents
    displayPageBreakState = ActiveSheet.DisplayPageBreaks
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
  src.Select
  Range("B19:G31").Select
  Application.CutCopyMode = False
  Selection.Copy
  raw.Select
  Range("A1").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Cells.Select
  On Error Resume Next
  Columns("C").SpecialCells(xlBlanks).EntireRow.Delete
  i = 1
  Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
	i = i + 1
  Loop
  For b = 1 To rng.Rows.Count
    If WorksheetFunction.CountA(rng.Rows(b)) <> 0 Then
    rng_dest.Rows(i).Value = rng.Rows(b).Value
      dest.Range("A" & i).Value = src.Range("F11").Value
      dest.Range("B" & i).Value = src.Range("E16").Value
      dest.Range("C" & i).Value = src.Range("E11").Value
      dest.Range("D" & i).Value = src.Range("B11").Value
      dest.Range("E" & i).Value = src.Range("E13").Value
      dest.Range("L" & i).Value = (src.Range("E34").Value) * (dest.Range("J" & i).Value)
      dest.Range("M" & i).Value = (dest.Range("J" & i).Value) + (dest.Range("K" & i).Value) - (dest.Range("L" & i).Value)
      dest.Range("N" & i).Value = src.Range("E15").Value
      dest.Range("O" & i).Value = src.Range("F32").Value
      dest.Range("P" & i).Value = src.Range("C38").Value
      dest.Range("Q" & i).Value = src.Range("B39").Value
      i = i + 1
    End If
    Next b
      dest.Range("A" & i).Value = src.Range("F11").Value
      dest.Range("B" & i).Value = src.Range("E16").Value
      dest.Range("C" & i).Value = src.Range("E11").Value
      dest.Range("D" & i).Value = src.Range("B11").Value
      dest.Range("E" & i).Value = src.Range("E13").Value
      dest.Range("H" & i).Value = "Grand Total for Invoice"
      dest.Range("K" & i).Value = src.Range("G36").Value
      dest.Range("L" & i).Value = src.Range("F34").Value
      dest.Range("M" & i).Value = src.Range("F37").Value
      dest.Range("N" & i).Value = src.Range("E15").Value
      dest.Range("O" & i).Value = src.Range("F32").Value
      dest.Range("P" & i).Value = src.Range("C38").Value
      dest.Range("Q" & i).Value = src.Range("B39").Value
      dest.Range("R" & i).Value = src.Range("C32").Value
      dest.Range("S" & i).FormulaR1C1 = "=IF(RC[1]="""",R1C19-RC[-17],"""")"
      dest.Range("V" & i).FormulaR1C1 = "=IF(RC[-2]="""","""",RC[-2]-RC[-20])"
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
  ActiveWorkbook.Sheets("Printable").Activate
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:="D:\PDF\Invoice " &_ 
        ActiveSheet.Range("F11").Value & ".pdf", _
        OpenAfterPublish:=False
        Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Invoice").Activate
  src.Select
  ActiveWorkbook.Sheets("DNote").Activate
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:="D:\PDF\DNote\DNote " & _
        ActiveSheet.Range("F11").Value & ".pdf", _
        OpenAfterPublish:=False
        Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Invoice").Activate
  src.Select
  Range("E11").Select
    Application.ScreenUpdating = screenUpdateState
    Application.DisplayStatusBar = statusBarState
    Application.Calculation = calcState
    Application.EnableEvents = eventsState
    ActiveSheet.DisplayPageBreaks = displayPageBreakState
End Sub

What am I doing wrong?

It looks messy I know...

Please help.

d

 

[nemmi69]

I use this function to delete duplicates and blank lines

'#########################################################
'Function DelDupArray() Remove blank lines and
' duplicates from an array.
'#########################################################
Function DelDupArray(InputArray As Variant) As Boolean


Dim LBArr As Long, UBArr As Long, NdX As Long
Dim Ast As Long, AEnd As Long, ACnt As Long, BCnt As Long


On Error GoTo ErrorCheck
If IsEmpty(InputArray) Then
    ErrMsg = "No array data."
    GoTo ErrorCheck
End If


DelDupArray = False
LBArr = LBound(InputArray)
UBArr = UBound(InputArray)


'check if 1st element is blank
If InputArray(LBArr) = "" Then
    For NdX = LBArr To UBound(InputArray) - 1
        InputArray(NdX) = InputArray(NdX + 1)
    Next NdX
    ReDim Preserve InputArray(LBound(InputArray) To UBound(InputArray) - 1)
    LBArr = LBound(InputArray)
    UBArr = UBound(InputArray)
End If


'Remove duplicates and blanks
ErrMsg = "Failed removing duplicates and blanks."
Application.StatusBar = "Removing duplicate lines . . ."
Ast = LBArr
AEnd = UBArr
ACnt = Ast
BCnt = Ast + 1


Do While ACnt <= AEnd
    Do While BCnt <= AEnd
        If InputArray(ACnt) = InputArray(BCnt) Or InputArray(BCnt) = "" Then
            For NdX = BCnt To UBound(InputArray) - 1
                InputArray(NdX) = InputArray(NdX + 1)
            Next NdX
            ReDim Preserve InputArray(LBound(InputArray) To UBound(InputArray) - 1)
            AEnd = AEnd - 1
        Else
            BCnt = BCnt + 1
        End If
    Loop
    ACnt = ACnt + 1
    BCnt = ACnt + 1
Loop
DelDupArray = True
On Error GoTo 0
Application.StatusBar = ""


Exit Function


ErrorCheck:
'Reset the application to its normal operating environment.
MsgBox ErrMsg, vbCritical, ThisWorkbook.Name
DelDupArray = False
On Error GoTo 0
Application.StatusBar = ""
End Function