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

• #22563 slashing senior tag Delila_1 #22562

  Új Válasz 2014-07-24 11:05:08 #22563

  Ú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

  

  slashing

  senior tag

  válasz Delila_1 #22562 üzenetére

  Bocsi nem voltam teljesen pontos a kijelölésig okés a dolog azzal abszolút nem kell foglalkozni csak a beillesztésen megy a variálás

  usor = Workbooks(WBN).Sheets(WS).Cells(1 & Columns.Count).End(xlToLeft).Column + 1
  selectRange.Copy
  Workbooks(WBN).Sheets(WS).Cells(6, usor).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False

  A kódod sokat segített annyi volt a hibám hogy a félkövér résznél & jelet használtam de átírva vesszőre már faszán egymás mellé kerülnek az adatok. most már csak annyi van hogy a B6-nál kezdi berakni az adatokat szóval el kéne tolni a D6-ig valahogy

  A teljes kód itt van, tuti emlékszel rá mindig abból a könyvtárból húzza be az adatokat ami a lap neve. Jelen esetben a B4:B tartományból szedi ki az adatokat és kerülnek át

  Sub XLSX()
  Dim Filename, Pathname As String, WBN As String, WS As String
  Dim wb As Workbook
  Application.ScreenUpdating = False
  WBN = ActiveWorkbook.Name
  WS = ActiveSheet.Name
  Pathname = "C:\bosch\" & WS & "\"
  Filename = Dir(Pathname & "*.txt")
  Do While Filename <> ""
  Set wb = Workbooks.Open(Pathname & Filename)
  DoWork wb, WBN, WS
  Application.CutCopyMode = False
  wb.Close SaveChanges:=False
  Filename = Dir()
  Loop
  
  Application.ScreenUpdating = True
  End Sub
  
  Sub DoWork(wb As Workbook, WBN, WS)
  Dim usor As Long, cell As Range, selectRange As Range, WS2 As String
  WS2 = ActiveSheet.Name
  With wb
  
  Dim cserelendo, b As Integer
  'Kötőjellel elválasztva add meg a törlendő szavakat
  cserelendo = Split("Tol*-Date*-Time*-File*-Lot*-No*-Distance(point-to-line)-'*-Actual-Nominal-Upper-Lower-Error-Judge-Pass-L", "-")
  'a ciklus hosszának egyel kevesebbnek kell lennie mint a cserélendó szavak mivel a nullát is feltölti
  For b = 0 To 17
  Cells.Replace What:=cserelendo(b), Replacement:="", LookAt:=xlPart, _
  SearchOrder:=xlByRows, MatchCase:=False
  Next
  'itt adod meg melyik oszlopból vegye az adatokat, ha az első Range oszlopa nem egyzik a következő Range tartományával akkor ott fogja kijelölni ahol keresztezi egymást a kettő
  usor = .Sheets(WS2).Range("B" & Rows.Count).End(xlUp).Row
  For Each cell In .Sheets(1).Range("B4:B" & usor)
  If (cell.Value <> "") Then
  If selectRange Is Nothing Then
  Set selectRange = cell
  Else
  Set selectRange = Union(cell, selectRange)
  End If
  End If
  Next cell
  'Itt adod meg melyik oszlopba pakolja az adatokat a Transpose True miatt lesz átfordítva oszlopból sorra
  usor = Workbooks(WBN).Sheets(WS).Cells(1 & Columns.Count).End(xlToLeft).Column + 1
  selectRange.Copy
  Workbooks(WBN).Sheets(WS).Cells(6, usor).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  End With
  End Sub

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