Estou desenvolvendo uma planilha que faz o seguinte:
ao inserir dados em linhas, o loop funciona bem. O problema é quando tento tranferir os dados de duas planilhas para uma terceira que mais parece um formulário.
Na primeira planilha os dados provém de uma única linha e da seguda planilha, 4 linhas com infomações referentes à linha da primeira planilha.
Como fazer com que o programa busque os dados a partir da quinta linha da segunda planilha no que se refere à segunda linha da primeira planilha?
Sabendo que, o valor de A1 da primeira planilha por exemplo, é o mesmo valor de A1,A2,A3 e A4 da segunda.
Na terceira, A1 da primeira planilha é o título, enquanto que as demais preenchen linhas específicas da planilha.
Pergunta
marblesmusic
Estou desenvolvendo uma planilha que faz o seguinte:
ao inserir dados em linhas, o loop funciona bem. O problema é quando tento tranferir os dados de duas planilhas para uma terceira que mais parece um formulário.
Na primeira planilha os dados provém de uma única linha e da seguda planilha, 4 linhas com infomações referentes à linha da primeira planilha.
Como fazer com que o programa busque os dados a partir da quinta linha da segunda planilha no que se refere à segunda linha da primeira planilha?
Sabendo que, o valor de A1 da primeira planilha por exemplo, é o mesmo valor de A1,A2,A3 e A4 da segunda.
Na terceira, A1 da primeira planilha é o título, enquanto que as demais preenchen linhas específicas da planilha.
O código é é este aqui... complexo ou não?
Pra mim é desafio! Ainda não consegui!
Demarquei o ponto em que acredito estar o erro!
Sub WordArt39_Clique()
Application.ScreenUpdating = False
Sheets("I.S").Visible = True
Sheets("Folha de elementos").Visible = True
Sheets("Compl. elementos").Visible = True
ri = ActiveCell.Row
Selection.End(xlDown).Select
rf = ActiveCell.Row
rqt = rf - ri + 1
FQT = Int(rqt / 4) + 1
If FQT > 10000 Then FQT = 1
RR = ri - 1
F = 0
Range("E" & r1 + 1).Select
numele = ActiveCell.Value
Range("C" & r1 + 1).Select
plata = ActiveCell.Value
With Range("e" & ri + 1).Select
Cells.Find(What:=numele, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Do While F < FQT
Sheets("Elementos").Select
F = F + 1
V = 0
For I = 1 To 4
If I = 1 Then
Range("F" & RR + I).Select
nomele = ActiveCell.FormulaR1C1
Range("C" & RR + I).Select
PLT = ActiveCell.FormulaR1C1
Range("I" & RR + I).Select
LCL = ActiveCell.FormulaR1C1
Range("D" & RR + I).Select
modelo = ActiveCell.FormulaR1C1
Range("E" & RR + I).Select
numele = ActiveCell.FormulaR1C1
Range("G" & RR + I).Select
baop = ActiveCell.FormulaR1C1
Range("J" & RR + I).Select
tempo = ActiveCell.FormulaR1C1
Range("L" & RR + I).Select
hest = ActiveCell.FormulaR1C1
Range("M" & RR + I).Select
dtest = ActiveCell.FormulaR1C1
Sheets("I.S").Select
Range("B94").Select
escr = ActiveCell.FormulaR1C1
Range("B94").Select
ct1 = ActiveCell.Value
Range("X94").Select
ct2 = ActiveCell.Value
Range("AY8").Select
sup1 = ActiveCell.Value
Range("BS8").Select
sup2 = ActiveCell.Value
Range("AT94").Select
eng1 = ActiveCell.Value
Range("BP94").Select
eng2 = ActiveCell.Value
Sheets("Compl. elementos").Select
Range("A" & RR + I).Select
numele = ActiveCell.FormulaR1C1
If F > 1 Then
If numele <> numele1 Then
FQT = FQT - 1
GoTo retry6
End If
End If
Sheets("Folha de elementos").Visible = True
Sheets("Folha de elementos").Select
Sheets("Folha de elementos").Copy After:=Sheets(7 + F - 1)
Sheets("Folha de elementos").Visible = False
If baop <> "O" Then
ActiveSheet.Shapes("Oval 2").Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("Oval 4").Select
Selection.ShapeRange.Fill.Visible = msoFalse
Else
If baop = "O" Then
ActiveSheet.Shapes("Oval 4").Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
ActiveSheet.Shapes("Oval 2").Select
Selection.ShapeRange.Fill.Visible = msoFalse
End If
End If
Range("S43").Select
If LCL = "C4" Then
ActiveSheet.Shapes("Rectangle 91").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "E4" Then
ActiveSheet.Shapes("Rectangle 83").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "C3" Then
ActiveSheet.Shapes("Rectangle 90").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "E3" Then
ActiveSheet.Shapes("Rectangle 82").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "C2" Then
ActiveSheet.Shapes("Rectangle 89").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "E2" Then
ActiveSheet.Shapes("Rectangle 81").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "E1" Then
ActiveSheet.Shapes("Rectangle 80").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "C1" Then
ActiveSheet.Shapes("Rectangle 84").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "D1" Then
ActiveSheet.Shapes("Rectangle 85").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "D2" Then
ActiveSheet.Shapes("Rectangle 86").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "D3" Then
ActiveSheet.Shapes("Rectangle 87").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
If LCL = "D4" Then
ActiveSheet.Shapes("Rectangle 88").Select
Selection.ShapeRange.Fill.Visible = msoTrue
End If
Range("X12").Select
ActiveCell.FormulaR1C1 = PLT
Range("z12").Select
ActiveCell.FormulaR1C1 = modelo
Range("ae12").Select
ActiveCell.FormulaR1C1 = numele
Range("b14").Select
ActiveCell.FormulaR1C1 = nomele
Range("ac13").Select
ActiveCell.FormulaR1C1 = escr
Range("e50").Select
ActiveCell.FormulaR1C1 = ct1
Range("h50").Select
ActiveCell.FormulaR1C1 = sup1
Range("m50").Select
ActiveCell.FormulaR1C1 = eng1
Range("e52").Select
ActiveCell.FormulaR1C1 = ct2
Range("h52").Select
ActiveCell.FormulaR1C1 = sup2
Range("m52").Select
ActiveCell.FormulaR1C1 = eng2
End If
------------------------------------------------------------------Sei que o erro pode estar aqui, falta alguma coisa?---------
numele1 = numele
Sheets("Compl. elementos").Select
Range("A" & RR + I).Select
numele = ActiveCell.FormulaR1C1
Range("J" & RR + I).Select
dtrev = ActiveCell.FormulaR1C1
Range("K" & RR + I).Select
alt = ActiveCell.FormulaR1C1
Range("L" & RR + I).Select
nrev = ActiveCell.FormulaR1C1
Range("M" & RR + I).Select
SIMB = ActiveCell.FormulaR1C1
If I > 1 Then
If numele <> numele1 Then GoTo retry6
End If
Range("j" & RR + I).Select
dtrev = ActiveCell.FormulaR1C1
Range("L" & RR + I).Select
nrev = ActiveCell.FormulaR1C1
Range("K" & RR + I).Select
alt = ActiveCell.FormulaR1C1
Range("B" & RR + I).Select
seq = ActiveCell.FormulaR1C1
Range("C" & RR + I).Select
ppri = ActiveCell.FormulaR1C1
Range("D" & RR + I).Select
pcha = ActiveCell.FormulaR1C1
Range("E" & RR + I).Select
raz = ActiveCell.FormulaR1C1
Range("F" & RR + I).Select
dtoque = ActiveCell.FormulaR1C1
Range("G" & RR + I).Select
hoque = ActiveCell.FormulaR1C1
Range("H" & RR + I).Select
dtqua = ActiveCell.FormulaR1C1
Range("I" & RR + I).Select
hqua = ActiveCell.FormulaR1C1
'------------------------------------------------------------------------------------------------------------
'If ppri = "" Then GoTo RETRY5
Sheets("Folha de elementos (" & F + 1 & ")").Select
If V < 4 Then
Application.GoTo Reference:="R44" & "C" & 29 + V
ActiveCell.FormulaR1C1 = hest
Application.GoTo Reference:="R50" & "C" & 29 + V
ActiveCell.FormulaR1C1 = dtest
Application.GoTo Reference:="R47" & "C" & 29 + V
ActiveCell.FormulaR1C1 = tempo
End If
If V < 3 Then
Range("Z" & 53 + V).Select
ActiveCell.FormulaR1C1 = dtrev
Range("AB" & 53 + V).Select
ActiveCell.FormulaR1C1 = nrev
Range("AC" & 53 + V).Select
ActiveCell.FormulaR1C1 = alt
End If
V = V + 1
'----------------------------------------------- texto distribuido passo principal
TXT = ppri
If I = 1 Then frf = 20
If I = 2 Then frf = 26
If I = 3 Then frf = 32
If I = 4 Then frf = 38
Range("U" & frf).Select
ActiveCell.FormulaR1C1 = seq
'----------------------------------------------------------------------- simbolo
If SIMB = "S" Then
ActiveSheet.Shapes("AutoShape 138").Select
Selection.Copy
Range("s" & frf + 1).Select
ActiveSheet.Paste
End If
If SIMB = "C" Then
ActiveSheet.Shapes("Group 135").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
End If
If SIMB = "que" Then
ActiveSheet.Shapes("AutoShape 134").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -48#
Selection.ShapeRange.IncrementTop -30#
End If
If SIMB = "O" Then
ActiveSheet.Shapes("Rectangle 139").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -21#
Selection.ShapeRange.IncrementTop -27#
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
End If
If SIMB = "SQ" Then
ActiveSheet.Shapes("AutoShape 138").Select
Selection.Copy
Range("s" & frf + 1).Select
ActiveSheet.Paste
ActiveSheet.Shapes("AutoShape 134").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -48#
Selection.ShapeRange.IncrementTop -30#
End If
If SIMB = "SC" Then
ActiveSheet.Shapes("AutoShape 138").Select
Selection.Copy
Range("s" & frf + 1).Select
ActiveSheet.Paste
ActiveSheet.Shapes("Group 135").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
End If
If SIMB = "SO" Then
ActiveSheet.Shapes("AutoShape 138").Select
Selection.Copy
Range("s" & frf + 1).Select
ActiveSheet.Paste
ActiveSheet.Shapes("Rectangle 139").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -21#
Selection.ShapeRange.IncrementTop -27#
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
End If
If SIMB = "QC" Then
ActiveSheet.Shapes("AutoShape 134").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -48#
Selection.ShapeRange.IncrementTop -30#
ActiveSheet.Shapes("Group 142").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
End If
If SIMB = "QO" Then
ActiveSheet.Shapes("AutoShape 134").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -48#
Selection.ShapeRange.IncrementTop -30#
ActiveSheet.Shapes("Rectangle 139").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -21#
Selection.ShapeRange.IncrementTop -27#
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
End If
If SIMB = "CO" Then
ActiveSheet.Shapes("Group 135").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
ActiveSheet.Shapes("Rectangle 139").Select
Selection.Copy
Range("S" & frf + 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -21#
Selection.ShapeRange.IncrementTop -27#
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
End If
'--------------------------------------------------------------------------
v3 = Len(TXT)
T = 40 't é a quantidade de caracter máxima por linha
If v3 < T Then
Range("v" & frf).Select
ActiveCell.FormulaR1C1 = ppri
GoTo RETRY3
End If
ct = 0
For Z = 1 To 500
j = Z
l = 1
Do
For y = j To Z + T
TXT1 = Mid(TXT, y, 1)
If TXT1 = " " Then
vi = y
End If
TXT1 = Mid(TXT, j, y)
Next
x = vi - j
If x > 0 Then
If v3 - j > T Then
TXTF = Mid(TXT, j, vi - j)
Else
TXTF = Mid(TXT, j, v3)
Range("v" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
fr1 = ActiveCell.Row
GoTo RETRY3
End If
Else
Range("v" & frf + ct).Select
ActiveCell.Formula = TXT1
GoTo RETRY3
End If
Range("v" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
Loop
Next
RETRY3:
'----------------------------------------------- texto distribuido ponto chave
TXT = pcha
If I = 1 Then frf = 20
If I = 2 Then frf = 26
If I = 3 Then frf = 32
If I = 4 Then frf = 38
v3 = Len(TXT)
T = 25 't é a quantidade de caracter máxima por linha
If v3 < T Then
Range("aa" & frf).Select
ActiveCell.FormulaR1C1 = pcha
GoTo retry31
End If
ct = 0
For Z = 1 To 500
j = Z
l = 1
Do
For y = j To Z + T
TXT1 = Mid(TXT, y, 1)
If TXT1 = " " Then
vi = y
End If
TXT1 = Mid(TXT, j, y)
Next
x = vi - j
If x > 0 Then
If v3 - j > T Then
TXTF = Mid(TXT, j, vi - j)
Else
TXTF = Mid(TXT, j, v3)
Range("aa" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
fr1 = ActiveCell.Row
GoTo retry31
End If
Else
Range("AA" & frf + ct).Select
ActiveCell.Formula = TXT1
GoTo retry31
End If
Range("aa" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
Loop
Next
retry31:
'----------------------------------------------- texto distribuido razao
TXT = raz
If I = 1 Then frf = 20
If I = 2 Then frf = 26
If I = 3 Then frf = 32
If I = 4 Then frf = 38
v3 = Len(TXT)
T = 28 't é a quantidade de caracter máxima por linha
If v3 < T Then
Range("ad" & frf).Select
ActiveCell.FormulaR1C1 = raz
GoTo retry32
End If
ct = 0
For Z = 1 To 500
j = Z
l = 1
Do
For y = j To Z + T
TXT1 = Mid(TXT, y, 1)
If TXT1 = " " Then
vi = y
End If
TXT1 = Mid(TXT, j, y)
Next
x = vi - j
If x > 0 Then
If v3 - j > T Then
TXTF = Mid(TXT, j, vi - j)
Else
TXTF = Mid(TXT, j, v3)
Range("ad" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
fr1 = ActiveCell.Row
GoTo retry32
End If
Else
Range("ad" & frf + ct).Select
ActiveCell.Formula = TXT1
GoTo retry32
End If
Range("ad" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
Loop
Next
retry32:
'----------------------------------------------- texto distribuido historico seguranca
TXT = hoque
If I = 1 Then frf = 61
If I = 2 Then frf = 79
If I = 3 Then frf = 97
If I = 4 Then frf = 113
Range("b" & frf).Select
ActiveCell.FormulaR1C1 = dtoque
v3 = Len(TXT)
T = 68 't é a quantidade de caracter máxima por linha
If v3 < T Then
Range("e" & frf).Select
ActiveCell.FormulaR1C1 = hoque
GoTo retry33
End If
ct = 0
For Z = 1 To 1000
j = Z
l = 1
Do
For y = j To Z + T
TXT1 = Mid(TXT, y, 1)
If TXT1 = " " Then
vi = y
End If
TXT1 = Mid(TXT, j, y)
Next
x = vi - j
If x > 0 Then
If v3 - j > T Then
TXTF = Mid(TXT, j, vi - j)
Else
TXTF = Mid(TXT, j, v3)
Range("e" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
fr1 = ActiveCell.Row
GoTo retry33
End If
Else
Range("E" & frf + ct).Select
ActiveCell.Formula = TXT1
GoTo retry33
End If
Range("e" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 2
Loop
Next
retry33:
'----------------------------------------------- texto distribuido historico qualidade
TXT = hqua
If I = 1 Then frf = 61
If I = 2 Then frf = 79
If I = 3 Then frf = 97
If I = 4 Then frf = 113
Range("w" & frf).Select
ActiveCell.FormulaR1C1 = dtqua
v3 = Len(TXT)
T = 68 't é a quantidade de caracter máxima por linha
If v3 < T Then
Range("y" & frf).Select
ActiveCell.FormulaR1C1 = hqua
GoTo retry34
End If
ct = 0
For Z = 1 To 1000
j = Z
l = 1
Do
For y = j To Z + T
TXT1 = Mid(TXT, y, 1)
If TXT1 = " " Then
vi = y
End If
TXT1 = Mid(TXT, j, y)
Next
x = vi - j
If x > 0 Then
If v3 - j > T Then
TXTF = Mid(TXT, j, vi - j)
Else
TXTF = Mid(TXT, j, v3)
Range("y" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 1
fr1 = ActiveCell.Row
GoTo retry34
End If
Else
Range("Y" & frf + ct).Select
ActiveCell.Formula = TXT1
GoTo retry34
End If
Range("y" & frf + ct).Select
ActiveCell.Formula = TXTF
j = vi + 1
Z = vi + 1
l = l + 1
ct = ct + 2
Loop
Next
retry34:
RETRY5:
Next
RR = RR + I - 1
Range("a1").Select
Loop
retry6:
A = Array(8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8)
For I = 2 To FQT
A(I) = 8 + I - 1
Next
Sheets("Elementos").Select
' ActiveSheet.ShowAllData
RETRY1:
Sheets("Compl. elementos").Visible = False
Sheets("I.S").Visible = False
Range("a7").Select
End With
End Sub
Link para o comentário
Compartilhar em outros sites
1 resposta a esta questão
Posts Recomendados
Participe da discussão
Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.