VBA if cell contains value then copy it-CodePudding

Hi looking for a simple VBA That would check column D from row10 to row 150 if cell contains value then copy that cell to D9 and do print activ sheet If cell is empty do nothing

I get data from 1 to 150 and need to print label I'm currently doing one buy one copy paste and print So if anyone could help I would appreciate it

CodePudding user response：

I am pretty much in my first steps in VBA, and I had a similar case to this so I will try to help you out with something you can work with.

I did no understand what you meant by 'do print activ sheet' but I guess I will let you search for that part on your own, here is a bit that would get you started :

Sub CheckIfCellContainsValue()
 Dim index As Integer, NumberOfRows As Integer, ActualCellValue As Variant
  NumberOfRows = Range("D10:D150").Rows.Count
  For index = 10 To NumberOfRows   9
    ActualCellValue = Range("D" & index).Value
    Debug.Print ActualCellValue
    If IsEmpty(ActualCellValue) Then
     ' Do nothing
    Else
     Range("D9").Value = ActualCellValue
     ' Insert your do print activ sheet code here.
    End If
    Set ActualCellValue = Nothing
  Next
End Sub

I know this looks complicated, and I welcome the community for any input to make my code less complex.

Cheers,

CodePudding user response：

Copy If Not Blank (and Not Error Value)

Option Explicit

Sub PrintForNonBlankCells()
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    ' Instead of the previous line, I prefer something like:
    'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim cCell As Range: Set cCell = ws.Range("D9") ' Criteria Cell
    
    Dim lrg As Range: Set lrg = ws.Range("D10:D150") ' Lookup Range
    ' To make the previous line dynamic instead, you could e.g. do:
    'Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp)
    'Dim lrg As Range: Set lrg = ws.Range("D10:D" & LastRow)
    
    Dim lCell As Range ' Lookup Cell
    For Each lCell In lrg.Cells
        If Not IsError(lCell) Then ' exclude error values
            If Len(lCell.Value) > 0 Then ' exclude blanks
                cCell.Value = lCell.Value
                ws.Calculate ' may not be necessary
                ws.PrintOut ' add the desired parameters (no parentheses)
            End If
        End If
    Next lCell

End Sub