Új hozzászólás Aktív témák

• #33162 róland veterán b3n1t0 #33158

  Új Válasz 2016-11-07 16:51:05 #33162

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  róland

  veterán

  válasz b3n1t0 #33158 üzenetére

  Köszönöm!

  Tetszik, de a makrómentes (céges policy miatt) munkafüzettel nem megy. Meg összetett táblázatoknak csak bizonyos részei kellenek a CSV-hez, így új munkafüzet lapra másolva lesz megoldva az exportálás.

• #32820 alfa20 senior tag b3n1t0 #32818

  Új Válasz 2016-09-30 14:51:23 #32820

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  alfa20

  senior tag

  válasz b3n1t0 #32818 üzenetére

  köszönöm, ezzel próbálkoztam, de az alábbi hiba üzenetet kapom a 'Controls'-ra:

  Method or data membernot found

• #32368 Delila_1 veterán b3n1t0 #32365

  Új Válasz 2016-08-19 14:05:07 #32368

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz b3n1t0 #32365 üzenetére

  A makrót modulba kell tenned.

  Sorra veszi az A oszlop dátumait. Ha van azoknak megfelelő lap a füzetben, akkor annak az első üres sorába másol. Ha nincs létrehozza a lapot.

  Mivel lapnévben nem szerepelhet a törtjel, helyette alsó kötőjelet ír. Az A oszlopban maradhat a törtjeles dátum, nem kell módosítanod.

  Sub Kulon_Lapra()
Dim sor As Long, lapnev As String, a, hova As Long

sor = 1
Do While Cells(sor, 1) <> ""
lapnev = Cells(sor, "A")
lapnev = Left(lapnev, 2) & "_" & Mid(lapnev, 4, 2) & "_" & Right(lapnev, 2)
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lapnev
Sheets(1).Activate
End If
On Error GoTo 0

hova = Application.WorksheetFunction.CountA(Sheets(lapnev).Columns(1)) + 1
Rows(sor).Copy Sheets(lapnev).Cells(hova, 1)
sor = sor + 1
Loop
End Sub

• #32228 Fferi50 Topikgazda b3n1t0 #32226

  Új Válasz 2016-08-02 12:58:03 #32228

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Fferi50

  Topikgazda

  válasz b3n1t0 #32226 üzenetére

  Szia!

  A következő makró egy új munkalapra kibontja a sorokat, úgy hogy minden új sor után tesz egy üres sort, illetve a legelső sorba beírja az eredeti értékeket - ezt a sort el tudod hagyni, ha kitörlöd, nem okoz semmi problémát, megjegyzésben mellé írtam.

  Sub kibonto()
Dim rngalap As Range, rngdatum As Range, wsh1 As Worksheet, wsh2 As Worksheet, xx As Integer, sor As Range, cl As Range
Set wsh1 = ActiveSheet
Set rngalap = Intersect(wsh1.UsedRange, wsh1.UsedRange.Parent.Columns("K:AH"))
Set wsh2 = Worksheets.Add(after:=Sheets(ActiveSheet.Name))
xx = 1
For Each sor In rngalap.Rows
sor.Copy Destination:=wsh2.Cells(xx, "K") ' ez az eredeti értéket tartalmazza, ha nincs rá szükséged akkor kitörölheted a következő sorral együtt
xx = xx + 1
Set rngdatum = wsh1.Range("AJ" & sor.Row & ":AQ" & sor.Row)
For Each cl In rngdatum.Cells
If IsEmpty(cl) Then Exit For
wsh2.Cells(xx, "K").Value = sor.Cells(1) + cl.Value
Range(wsh2.Cells(xx, "L"), wsh2.Cells(xx, "O")).Value = Range(sor.Cells(2), sor.Cells(5)).Value
Range(wsh2.Cells(xx, "P"), wsh2.Cells(xx, "AH")).Formula = "=int(" & sor.Cells(6).Address(external:=True, columnabsolute:=False) & "*" & cl.Offset(0, 8).Address(external:=True, rowabsolute:=True, columnabsolute:=True) & "/ 100)"
Range(wsh2.Cells(xx, "P"), wsh2.Cells(xx, "AH")).Value = Range(wsh2.Cells(xx, "P"), wsh2.Cells(xx, "AH")).Value
xx = xx + 1
Next
xx = xx + 1
Next
End Sub

  Üdv.

• #32227 bsasa1 csendes tag b3n1t0 #32226

  Új Válasz 2016-08-02 11:36:29 #32227

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  bsasa1

  csendes tag

  válasz b3n1t0 #32226 üzenetére

  Szia!

  Hát nem vagyok valami nagy vba-s, de egy régebbi makrómat átszabtam a tábládra.
  Sor azonosítók nem látszódnak, feltételeztem, hogy a 2. sorban van adat.
  Nálam működik, de egy hozzáértő biztos szebben oldaná meg.

  Sub makro1()

Dim i As Integer, j As Integer, f As Integer
Dim sor As Integer, hova As Integer

hova = InputBox(prompt:="Hányadik sorba?") - 1
sor = Range(("K2"), Range("K2").End(xlDown)).Rows.Count

For i = 1 To sor
For j = 1 To 8
Range("K" & hova + (i - 1) * 8 + j) = Range("K" & 1 + i) + Cells(2 + i - 1, 36 + j - 1)
Range("L" & 1 + i & ":O" & 1 + i).Copy Destination:=Range("L" & hova + (i - 1) * 8 + j & ":O" & hova + (i - 1) * 8 + j)
For f = 1 To 19
Cells(hova + (i - 1) * 8 + j, 16 + f - 1) = Cells(1 + i, 16 + f - 1) * Cells(2 + i - 1, 44 + j - 1)
Next f
Next j
Next i

End Sub

  a nullás sorok törlése kimaradt véletlen, de előbb ebéd

Új hozzászólás Aktív témák