Barreiro, não entendi o que quis dizer com "como definir eDietas ?", esta Variável já está definida na instrução "Set eDietas = ws3.Range("b4:c53")".
Se está tendo mensagem de erros, talvez não seja nela, verifique seu código linha por linha, lembro que no teste que fiz no dia após estes acertos, não deu erro.
O único erro que vai dar, é o que comentei no post anterior referente a qde de linhas, na contagem está considerando até a linha 88 e só tem 19 registros, e quando o procv encontrar "vazio" vai dar erro, então ou tem de adicionar uma condição para sair qdo vazia ou alterar a forma que considera os ranges.
A rotina completa ficaria assim com as modificações citadas anteriormente :
Sub Emite_Etiquetas()
'
'Autor: Carlos Frederico Bastos
'Data: 20170927
'Objetivo: Emissão de Etiquetas
'
Dim i, j, k, m, n, x As Integer
Dim eLin1 As Integer
Dim eTeste As String
Dim ws1, ws2, ws3 As Worksheet
Dim eDietas As Range
'
Set ws1 = Sheets.Application.ActiveSheet
Set ws2 = Sheets("Etiqueta")
Set ws3 = Sheets("CONTAGEM DIARIA")
Set eDietas = ws3.Range("b4:c53")
'
i = 9
eAndar = ws1.[C4]
eLin1 = i
eRefeicao = ws1.[H4]
'
With ws2
For i = i To ws1.[b90] + 9
j = 1
For j = j To 47 Step 11
k = 1
For k = k To 2
If k = 1 Then
eB1 = "C" & j ' Local
eB2 = "C" & (j + 1) ' Paciente
eD1 = "D" & (j + 2) ' Idade
eD2 = "D" & (j + 3) ' Refeição
eC1 = "C" & (j + 6) ' Dieta
eC2 = "C" & (j + 7) ' Característica
eC3 = "B" & (j + 8) ' Obs
eCelA = "A" & eLin1
eCelB = "B" & eLin1
eCelC = "C" & eLin1
eCelD = "D" & eLin1
eCelE = "E" & eLin1
eCelF = "F" & eLin1
eCelG = "G" & eLin1
'edieta = Application.WorksheetFunction.VLookup(eCelE, eDietas, 2, False)
edieta = Application.WorksheetFunction.VLookup(Range(eCelE).Value, eDietas, 2, False)
MsgBox edieta
.Range(eB1).Value = ws1.Range(eCelA).Value
.Range(eB2).Value = ws1.Range(eCelB).Value
.Range(eD1).Value = ws1.Range(eCelC).Value
.Range(eD2).Value = eRefeicao
.Range(eC1).Value = ws1.Range(eCelE).Value
.Range(eC2).Value = ws1.Range(eCelF).Value
.Range(eC3).Value = ws1.Range(eCelG).Value
Else
eI1 = "J" & j
eI2 = "J" & (j + 1) '2
eM1 = "K" & (j + 2) '3
eM2 = "K" & (j + 3) '4
eK1 = "J" & (j + 5) '6
eK2 = "J" & (j + 6) '7
eK3 = "I" & (j + 8) '9
eCelA = "A" & eLin1
eCelB = "B" & eLin1
eCelC = "C" & eLin1
eCelD = "D" & eLin1
eCelE = "E" & eLin1
eCelF = "F" & eLin1
eCelG = "G" & eLin1
.Range(eI1).Value = ws1.Range(eCelA).Value
.Range(eI2).Value = ws1.Range(eCelB).Value
.Range(eM1).Value = ws1.Range(eCelC).Value
.Range(eM2).Value = eRefeicao
.Range(eK1).Value = ws1.Range(eCelE).Value
.Range(eK2).Value = ws1.Range(eCelF).Value
.Range(eK3).Value = ws1.Range(eCelG).Value
End If
eLin1 = eLin1 + 1
x = ws1.[b90]
i = i + 1
If i > ws1.[b90] + 10 Then
i = 9
Exit For
End If
Next k
Next j
' i = i - 1
.PageSetup.PrintArea = ""
.PageSetup.PrintArea = .Range("B1:N54").Address
'.PrintOut
.PrintPreview
m = 1
For m = m To 47 Step 11
n = 1
For n = n To 2
If n = 1 Then
eB1 = "C" & m ' Local
eB2 = "C" & (m + 1) ' Paciente
eD1 = "D" & (m + 2) ' Idade
eD2 = "D" & (m + 3) ' Refeição
eC1 = "C" & (m + 5) ' Dieta
eC2 = "C" & (m + 6) ' Característica
eC3 = "B" & (m + 8) ' Obs
.Range(eB1).Value = ""
.Range(eB2).Value = ""
.Range(eD1).Value = ""
.Range(eD2).Value = ""
.Range(eC1).Value = ""
.Range(eC2).Value = ""
.Range(eC3).Value = ""
Else
eI1 = "J" & m
eI2 = "J" & (m + 1)
eM1 = "K" & (m + 2)
eM2 = "K" & (m + 3)
eK1 = "J" & (m + 6)
eK2 = "J" & (m + 7)
eK3 = "I" & (m + 8)
.Range(eI1).Value = ""
.Range(eI2).Value = ""
.Range(eM1).Value = ""
.Range(eM2).Value = ""
.Range(eK1).Value = ""
.Range(eK2).Value = ""
.Range(eK3).Value = ""
End If
Next n
Next m
Next i
End With
End Sub
[]s
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 16/11/2017 10:24 am