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

• #27002 Cifu félisten Árnymester #26982

  Új Válasz 2015-05-20 13:24:21 #27002

  Ú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

  

  Cifu

  félisten

  válasz Árnymester #26982 üzenetére

  Próbálkozom, de sehogy sem sikerül....

  A probléma (ha jól látom) a következő:

  A nekem nem külön munkalapokra, hanem komplett excell fájlokba kellene másolnom, tehát a '2014q3.xlsx' fájl 'munkalap1' munkalapján vannak az adatok, a második oszlopba vannak a vonalkódok, aztán az adatok a következőkbe (pár oszlop lényegtelen a számomra).

  Ezekből kéne 'C oszlop' nevű új workbookot (.xlsx) fájlt létrehozni, amelybe átmásolom az adott sor bizonyos celláinak tartalmát, majd a fájlt bezárni, és folytatni a következő sorral.

  Szóval valami ilyesmi lenne (csak ez még mindig nem működik ):

  Sub WorkbooksAdd()

  Dim munkalap1 As Worksheet
  Dim wborig As Workbook
  Dim r As Integer, count As Integer

  Set wborig = "2014q3_int.xlsx"
  Set munkalap1 = ActiveSheet
  r = 5
  Do Until Not IsEmpty(munkalap1(r, B))

  Application.ScreenUpdating = False

  y = (wborig.munkalap1(r, C)

  strPath = ThisWorkbook.Path

  Workbooks.Add

  ActiveWorkbook.SaveAs Filename:=y.Name

  'Címsor másolása
  ActiveSheet.Cells(1, 1).Value = wborig.munkalap1.Cells(4, B)
  ActiveSheet.Cells(1, 2).Value = wborig.munkalap1.Cells(4, C)
  ActiveSheet.Cells(1, 3).Value = wborig.munkalap1.Cells(4, D)
  ActiveSheet.Cells(1, 4).Value = wborig.munkalap1.Cells(4, K)
  ActiveSheet.Cells(1, 5).Value = wborig.munkalap1.Cells(4, T)
  'Adatok másolása
  ActiveSheet.Cells(2, 1).Value = wborig.munkalap1.Cells(r, B)
  ActiveSheet.Cells(2, 2).Value = wborig.munkalap1.Cells(r, C)
  ActiveSheet.Cells(2, 3).Value = wborig.munkalap1.Cells(r, D)
  ActiveSheet.Cells(2, 4).Value = wborig.munkalap1.Cells(r, K)
  ActiveSheet.Cells(2, 5).Value = wborig.munkalap1.Cells(r, T)

  For Each wb In Application.Workbooks
  If Not wb.Name = ThisWorkbook.Name Then wb.Close SaveChanges:=True

  r = r + 1
  Loop

  Application.ScreenUpdating = True

  End Sub

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