Transferência De Dados

marblesmusic · Março 21, 2007

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

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

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)

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

'----------------------------------------------- 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)

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

'----------------------------------------------- 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)

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

'----------------------------------------------- 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)

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

'----------------------------------------------- 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)

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

RETRY5:

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

' ActiveSheet.ShowAllData

RETRY1:

Sheets("Compl. elementos").Visible = False

Sheets("I.S").Visible = False

Range("a7").Select

End With

End Sub

marblesmusic · Março 27, 2007

Olá pessoal consegui resolver o problema!

Fiz um inversão de colunas em planilhas e deu certo, talvez eu não tivesse planejado bem as referências!

Também respondo dúvidas de vba através do meu e-mail uma vez por semana: marblesmusic@terra.com.br

Sempre aos Sábados!

Entrar

Transferência De Dados

Pergunta

marblesmusic

Link para o comentário

Compartilhar em outros sites

1 resposta a esta questão

Posts Recomendados

marblesmusic

Link para o comentário

Compartilhar em outros sites

Participe da discussão

Estatísticas dos Fóruns

Navegação

Atividades