Hjælp til vb kode

Prøv at tilføje .xls til WBname de steder hvor Workbooks bruges:

If Workbooks(WBName & ".xls").Worksheets(ShName).Range("K:K").Find(CheckID, LookIn:=xlValues) Is Nothing Then


Eller det måske lettere at tilføje til variablen WBName så det ikke er så mange steder det skal rettes:

WBName = Format(Date, "mmmm") & ".xls"
ShName = Format(Date, "d")
Workbooks.Open Filename:="C:\Test\" & WBName

Nej det gjore ikke noget... bare det samme... :S

Kan man lave det på en anden måde!?

Du kan prøve at skrive:

Workbooks(1).xxx

hvor!?..

Hvis jeg laver det sådan... laver den ikke nogle fejl men så gør den heller ikke noget... :S

WBName = (Sheets("A").Range("A1"))
ShName = (Sheets("A").Range("B1"))
Workbooks.Open Filename:="C:\excel\" & WBName '.Range("K:K")

Prøv at skrive tallet 1 i stedet for variablen WBName eks:

If Workbooks(1).Worksheets(ShName).Range("K:K").Find(CheckID, LookIn:=xlValues) Is Nothing Then

Lvaer bare samme fejl...

laver*

Kan man bruge en anden kode!?

Denne virker nu!? kan vi så ikke lige få den til kun at rækker ud fra C2:C25 Hvis de hav værdi og lave fed ramme om når den sætter det ind Rammen skal være + 6 Celler til højer!?

Sub CopySheet()

CheckID = Sheets("T").Range("M2")
IDExist = False

WBName = Format(Date, "mmmm") & ".xls"
ShName = Format(Date, "d")
Workbooks.Open Filename:="C:\excel\" & WBName
Workbooks("vognx.xls").Activate

If Workbooks(WBName).Worksheets(ShName).Range("K:K").Find(CheckID, LookIn:=xlValues) Is Nothing Then
    LastRow = Workbooks(WBName).Worksheets(ShName).Cells.SpecialCells(xlLastCell).Row
    Sheets("T").Range("C2:O25").Copy Workbooks(WBName).Worksheets(ShName).Range("A" & LastRow + 1)
End If

Workbooks(WBName).Close savechanges:=True

End Sub

Kom med et svar Eagleeye

ok, så må det være i dene linie at source range skal rettes:

  Sheets("T").Range("C2:O25").Copy Workbooks(WBName).Worksheets(ShName).Range("A" & LastRow + 1)

Til:
  Sheets("T").Range("C2:C25").Copy Workbooks(WBName).Worksheets(ShName).Range("A" & LastRow + 1)

Det er kun Hvis der er værdi i c2:C6= Copy C2:O6 Hvis der er værdi i C2:C8 Bliver det til C2:O8

Kan du så bruge dette:

if Application.Count(Columns("C7:C8")) > 0 then
  Sheets("T").Range("C2:O8").Copy Workbooks(WBName).Worksheets(ShName).Range("A" & LastRow + 1)
elseif Application.Count(Columns("C2:C6")) > 0 then
  Sheets("T").Range("C2:O6").Copy Workbooks(WBName).Worksheets(ShName).Range("A" & LastRow + 1)
end if

Tænker mere på en shift+Ctrl+ned på C2 & ud til O?
for der kan være data i alle Celler i C2:C25

eller sådan noget
Antal = Application.WorksheetFunction.Count(Worksheets("T").Range("C1:C25"))
If Antal > 0 Then
    Sheets("T" & Int((Antal + 1) / 2)).Copy Workbooks(WBName).Worksheets(ShName).Range("A" & LastRow + 1)
End If

Kan du forklare hvad du ønsker for jeg er vist ikke helt med nu. Cellerne C2:C25 skal kopier og der skal en ramme omkring?

Det som den skal kopier er det som denne kode mærker den fonktion som koden har vil jeg have med over
    Dim i As Long
    Dim it
    Dim C As Range
    Dim rngUnion As Range
    Dim rngCol As New Collection
    Dim bFound As Boolean

    For Each C In Range("C2:C25")
    If Not IsEmpty(C.Value) Then
            rngCol.Add Item:=C.Offset(, -0).Resize(1, 13)
            bFound = True
        End If
    Next

    If bFound Then
        Set rngUnion = rngCol.Item(1)
        For Each it In rngCol
            Set rngUnion = Union(rngUnion, it)
        Next
       
        rngUnion.Select
    End If
End Sub

Den kode som er ovenover mærker ud fra værdier i C2:C25 og ud fra de værdier mærker den ud til O? så den kun mærker seller med værdi i C2:O25. Next Nor den har smidt det ind på det ark som datoen/Faneblad Dagen/A:lastrow hvor den smider det ind A?:M? Efter det skal den lave et offset på -6 så den har Fra A?:S? Det den lige har overført og lave tyn ramme om de celler og fed kant og mærkningen.