Moi, olisko jollai ideaa, kuinka tällasta koodia sais siistittyy ja että sen sais toimiin isommallakin tiedostolla. Saiskoha siitä semmosta silmukkaa aikaseks.
Sub Button2_Click()
Dim areaT1, areaT2, cellT1, cellT2
Sheets("Sheet2").Activate
areaT2 = "B1:B" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
Sheets("Sheet1").Activate
areaT1 = "A1:A" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each cellT1 In Sheets("Sheet1").Range(areaT1)
For Each cellT2 In Sheets("Sheet2").Range(areaT2)
If cellT1.Value = cellT2.Value Then
Cells(cellT1.Row, 3).Value = Sheets("Sheet2").Cells(cellT2.Row, 1).Value
Cells(cellT1.Row, 4).Value = Sheets("Sheet2").Cells(cellT2.Row, 3).Value
End If
Next
Next
Application.ScreenUpdating = True
Dim areaT3, areaT4, cellT3, cellT4
Sheets("Sheet2").Activate
areaT4 = "D1:D" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
Sheets("Sheet1").Activate
areaT3 = "A1:A" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each cellT3 In Sheets("Sheet1").Range(areaT3)
For Each cellT4 In Sheets("Sheet2").Range(areaT4)
If cellT3.Value = cellT4.Value Then
Cells(cellT3.Row, 5).Value = Sheets("Sheet2").Cells(cellT4.Row, 1).Value
Cells(cellT3.Row, 6).Value = Sheets("Sheet2").Cells(cellT4.Row, 5).Value
End If
Next
Next
Application.ScreenUpdating = True
Dim areaT5, areaT6, cellT5, cellT6
Sheets("Sheet2").Activate
areaT6 = "G1:G" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
Sheets("Sheet1").Activate
areaT5 = "A1:A" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each cellT5 In Sheets("Sheet1").Range(areaT5)
For Each cellT6 In Sheets("Sheet2").Range(areaT6)
If cellT5.Value = cellT6.Value Then
Cells(cellT5.Row, 7).Value = Sheets("Sheet2").Cells(cellT6.Row, 1).Value
Cells(cellT5.Row, 8).Value = Sheets("Sheet2").Cells(cellT6.Row, 8).Value
End If
Next
Next
Application.ScreenUpdating = True
Dim areaT7, areaT8, cellT7, cellT8
Sheets("Sheet2").Activate
areaT8 = "I1:I" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
Sheets("Sheet1").Activate
areaT7 = "A1:A" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each cellT7 In Sheets("Sheet1").Range(areaT7)
For Each cellT8 In Sheets("Sheet2").Range(areaT8)
If cellT7.Value = cellT8.Value Then
Cells(cellT7.Row, 9).Value = Sheets("Sheet2").Cells(cellT8.Row, 1).Value
Cells(cellT7.Row, 10).Value = Sheets("Sheet2").Cells(cellT8.Row, 10).Value
End If
Next
Next
Application.ScreenUpdating = True
Dim areaT9, areaT10, cellT9, cellT10
Sheets("Sheet2").Activate
areaT10 = "L1:L" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
Sheets("Sheet1").Activate
areaT9 = "A1:A" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each cellT9 In Sheets("Sheet1").Range(areaT9)
For Each cellT10 In Sheets("Sheet2").Range(areaT10)
If cellT9.Value = cellT10.Value Then
Cells(cellT9.Row, 11).Value = Sheets("Sheet2").Cells(cellT10.Row, 1).Value
Cells(cellT9.Row, 12).Value = Sheets("Sheet2").Cells(cellT10.Row, 13).Value
End If
Next
Next
Application.ScreenUpdating = True
Dim areaT11, areaT12, cellT11, cellT12
Sheets("Sheet2").Activate
areaT12 = "N1:N" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
Sheets("Sheet1").Activate
areaT11 = "A1:A" & CStr(Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each cellT11 In Sheets("Sheet1").Range(areaT11)
For Each cellT12 In Sheets("Sheet2").Range(areaT12)
If cellT11.Value = cellT12.Value Then
Cells(cellT11.Row, 13).Value = Sheets("Sheet2").Cells(cellT12.Row, 1).Value
Cells(cellT11.Row, 14).Value = Sheets("Sheet2").Cells(cellT12.Row, 15).Value
End If
Next
Next
Application.ScreenUpdating = True
End Sub
apuja vääntöön
Walt
0
291
Vastaukset
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
En usko et meistä tulee jotain
Se ei kuitenkaan estä toivomasta et tulisi. Toivon et voitas suudella ja se sais asioita loksahtamaan paikoilleen. Jutel102860- 1152135
Eini paljastaa nuorekkuutensa salaisuuden - Tämä nousee framille: "Se on pakko, että jaksaa!"
Discokuningatar Eini on täyttänyt upeat 64 vuotta. Lavoilla ja keikoilla nähdään entistä vapautuneempi artisti, joka ei431554- 2601398
- 701003
Olen J-mies
Jos kerrot sukunimeni alkukirjaimen, ja asuinpaikkakuntani. Lupaan ottaa yhteyttä sinuun.47911- 55884
Ei sitten, ei olla enää
Missään tekemisissä. Unohdetaan kaikki myös se että tunsimme. Tätä halusit tämän saat. J miehelle. Rakkaudella vaalea na77880- 44785
Ma 30.9 tosiko tv klo 18 suorana Tikkalanmäeltä
Virastolta suorana. Äänestyksistä sitten puhutaan illalla ja huomenna, onko kepuvasemmisto kuntalaisten tahdon mukaan to93736