Boa noite. o problema em questão que não estou conseguindo deixar em negrito duas informações que se encontram na mesma linha., conforme foto em anexo.
As demais informações que desejo e foi programado para macro, está funcionando perfeitamente.
Tentei mesclar duas células "A:B", e onde tem duas informações na mesma linha uma ficou na coluna a e a outra na b, então funcionou perfeitamente, porem quando gero mais de uma etiqueta, a mesma fica sobreposta. e a intenção é deixa-las uma ao lado da outra, e se necessário preencher a folha, no case seria as etiquetas em duas colunas.
Foto como deverá ficar a etiqueta está em anexo.
Sub Ret?ngulodecantosarredondados1_Clique()
'Sub Gera_Etiqueta()
Application.ScreenUpdating = False
Dim MateriaPrima As String
Dim Lin As Integer
Dim U_L As Integer
Dim I As Integer
Dim Qtde As Integer
Dim Fornecedor As String
Dim DataRecebimento As String
Dim LoteFornecedor As String
Dim LoteFabricante As String
Dim CodigoProduto As String
Dim S As String ' sitema de corte
Dim Cod_Rastreio As String
Dim Col As Integer
Dim ik As Integer
Dim Receb As Date
Dim LOTE As Integer
Dim NCQ As String
Dim Fabricacao As String
Dim Validade As String
Sheets("COD BARRAS").Activate 'GUIA "IMP"
Sheets("COD BARRAS").DrawingObjects.Delete 'GUIA "IMP"
U_L = Sheets("CAD BARRAS").Range("A" & Rows.Count).End(xlUp).Row 'GUIA "GERADOR"
Lin = 1: Col = 1
For I = 2 To U_L
MateriaPrima = Sheets("CAD BARRAS").Range("B" & I) 'GUIA "GERADOR"
CodigoProduto = Sheets("CAD BARRAS").Range("C" & I)
Fornecedor = Sheets("CAD BARRAS").Range("D" & I)
DataRecebimento = Sheets("CAD BARRAS").Range("E" & I)
NCQ = Sheets("CAD BARRAS").Range("A" & I)
Fabricacao = Sheets("CAD BARRAS").Range("f" & I)
Validade = Sheets("CAD BARRAS").Range("G" & I)
LoteFornecedor = Sheets("CAD BARRAS").Range("h" & I)
LoteFabricante = Sheets("CAD BARRAS").Range("I" & I)
Qtde = Sheets("CAD BARRAS").Range("J" & I) 'GUIA "GERADOR"
'S = Sheets("REFERENCIA").Range("H" & I) 'sistema de corte
'Cod_Rastreio = Sheets("REFERENCIA").Range("I" & I) 'c?d. rastreio
Sheets("RESUMO").Activate 'GUIA "IDENTIFICACAO"
Sheets("resumo").Range("A2") = "MATERIA-PRIMA:" & MateriaPrima 'GUIA "IDENTIFICACAO"
With Sheets("resumo").Range("a2")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("resumo").Range("A3") = "DATA DE RECEBIMENTO:" & DataRecebimento
With Sheets("resumo").Range("a3")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("resumo").Range("a4") = "C?DIGO:" & CodigoProduto '& " " & "N? DO CQ:" & NCQ
With Sheets("resumo").Range("a4")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("resumo").Range("B4") = "N? DO CQ:" & NCQ
With Sheets("resumo").Range("a4")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("RESUMO").Range("A5") = "FORNECEDOR:" & Fornecedor
With Sheets("resumo").Range("a5")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("RESUMO").Range("A6") = "LOTE DO FORNECEDOR:" & LoteFornecedor
With Sheets("resumo").Range("a6")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("RESUMO").Range("A7") = "LOTE DO FORNECEDOR:" & LoteFabricante 'sistema de corte
With Sheets("resumo").Range("a7")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("RESUMO").Range("A8") = "FABRICA??O:" & Fabricacao '& " " & "VALIDADE:" & Validade 'sistema de corte
With Sheets("resumo").Range("a8")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("RESUMO").Range("a8") = "VALIDADE:" & Validade 'sistema de corte
With Sheets("resumo").Range("B8")
.Font.FontStyle = "regular"
.Characters(1, InStr(.Value, ":")).Font.Bold = True
End With
Sheets("resumo").Range("A1:b8").Copy 'GUIA "IDENTIFICACAO"
Sheets("COD BARRAS").Activate 'GUIA "IMP"
For ik = 1 To Qtde
Sheets("COD BARRAS").Cells(Lin, Col).Select 'GUIA "IMP"
' Sheets("COD BARRAS").Cells(Lin, Col).Select 'GUIA "IMP"
Sheets("COD BARRAS").Pictures.Paste 'GUIA "IMP"
Col = Col + 1
If Col = 3 Then
Lin = Lin + 1
Col = 1
End If
Next ik
Next I
' For ik = 1 To Qtde
'
' Sheets("COPIAS QUADROS").Cells(Lin, COL).Select 'GUIA "IMP"
' 'Sheets("COPIAS QUADROS").Cells(Lin, COL).Select 'GUIA "IMP"
' Sheets("COPIAS QUADROS").Pictures.Paste 'GUIA "IMP"
'
' COL = COL + 1
' If COL = 4 Then
' Lin = Lin + 1
' COL = 1
' End If
' Next
' Next
'Unload UserForm1
Application.ScreenUpdating = True
ActiveWindow.SelectedSheets.PrintPreview
'ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
'Sheets("CAD BARRAS").Select
'End Sub
End Sub
Postado : 25/07/2018 9:58 pm