Excell çoklu seçilen satılar nasıl hata almadan nasıl kopya?

Excel, Word, Access, Power Point programlarıyla ilgili ipuçları ve bilgi paylaşım alanıdır.
Cevapla
Kullanıcı avatarı
Mendenn
Gigabyte2
Gigabyte2
Mesajlar: 2356
Kayıt: 19 Haz 2006, 18:01
cinsiyet: Erkek
İletişim:

Excell çoklu seçilen satılar nasıl hata almadan nasıl kopya?

Mesaj gönderen Mendenn » 21 May 2011, 13:51

Copying a Multiple Selection
Bilindiği farklı satırlardaki verileri seçtiğinizde ve kopyaladığınızda Bu komut çoklu seçimlerde kullanılmaz diyor. onun ne yapabilirim.

nette bir takım code lar var ama nasıl kullanacağımı bilmiyorum..

----------------------------

Kod: Tümünü seç

Option Explicit
Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
    
    Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column G has the criteria eg project ref
    wsAll.Range("G1:G" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
        
    Next I
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

------------------------------------------------

Kod: Tümünü seç

http://j-walk.com/ss/excel/tips/tip36.htm

Kod: Tümünü seç

Option Explicit

Sub CopyMultipleSelection()
    Dim SelAreas() As Range
    Dim PasteRange As Range
    Dim UpperLeft As Range
    Dim NumAreas As Integer, i As Integer
    Dim TopRow As Long, LeftCol As Integer
    Dim RowOffset As Long, ColOffset As Integer
    Dim NonEmptyCellCount As Integer
    
'   Exit if a range is not selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select the range to be copied. A multiple selection is allowed."
        Exit Sub
    End If
    
'   Store the areas as separate Range objects
    NumAreas = Selection.Areas.Count
    ReDim SelAreas(1 To NumAreas)
    For i = 1 To NumAreas
        Set SelAreas(i) = Selection.Areas(i)
    Next
    
'   Determine the upper left cell in the multiple selection
    TopRow = ActiveSheet.Rows.Count
    LeftCol = ActiveSheet.Columns.Count
    For i = 1 To NumAreas
        If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
        If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
    Next
    Set UpperLeft = Cells(TopRow, LeftCol)
    
'   Get the paste address
    On Error Resume Next
    Set PasteRange = Application.InputBox _
      (Prompt:="Specify the upper left cell for the paste range:", _
      Title:="Copy Mutliple Selection", _
      Type:=8)
    On Error GoTo 0
'   Exit if canceled
    If TypeName(PasteRange) <> "Range" Then Exit Sub

'   Make sure only the upper left cell is used
    Set PasteRange = PasteRange.Range("A1")
    
'   Check paste range for existing data
    NonEmptyCellCount = 0
    For i = 1 To NumAreas
        RowOffset = SelAreas(i).Row - TopRow
        ColOffset = SelAreas(i).Column - LeftCol
        NonEmptyCellCount = NonEmptyCellCount + _
            Application.CountA(Range(PasteRange.Offset(RowOffset, ColOffset), _
            PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1, _
            ColOffset + SelAreas(i).Columns.Count - 1)))
    Next i
    
'   If paste range is not empty, warn user
    If NonEmptyCellCount <> 0 Then _
        If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
        "Copy Multiple Selection") <> vbYes Then Exit Sub

'   Copy and paste each area
    For i = 1 To NumAreas
        RowOffset = SelAreas(i).Row - TopRow
        ColOffset = SelAreas(i).Column - LeftCol
        SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
    Next i
End Sub 
Beni bir tek sen anladın ama sende yanlış anladın be gülüm..!



Kullanıcı avatarı
Mendenn
Gigabyte2
Gigabyte2
Mesajlar: 2356
Kayıt: 19 Haz 2006, 18:01
cinsiyet: Erkek
İletişim:

Re: Excell çoklu seçilen satılar nasıl hata almadan nasıl ko

Mesaj gönderen Mendenn » 21 May 2011, 16:11

Kod: Tümünü seç

Sub thirdmatch()

Dim arrKey() As Variant
Dim arrOut() As Variant
Dim rowCnt As Integer
Dim rr As Integer
Dim rOut As Integer
Dim i As Integer

Dim s1 As Worksheet
Dim s2 As Worksheet
Dim r1 As Range
Dim r2 As Range

Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Set r1 = s1.Range("A2", s1.Range("A4"))
Set r2 = s2.Range("A2")

rowCnt = s1.Range("A1", s1.Range("A1").End(xlDown)).Count
rr = 0
rOut = 0

Do While rr < rowCnt
    arrKey = r1.Offset(rr, 0)
    If arrKey(1, 1) = arrKey(2, 1) And arrKey(2, 1) = arrKey(3, 1) And arrKey(1, 1) = 1 Then
        arrOut = s1.Range("A" & rr + 4, s1.Range("BB" & rr + 4))
        For i = 1 To 54
            r2.Offset(rOut, i - 1) = arrOut(1, i)
        Next i
        rOut = rOut + 1
    End If
    rr = rr + 1
Loop

End Sub
Beni bir tek sen anladın ama sende yanlış anladın be gülüm..!

Kullanıcı avatarı
velociraptor
Yottabyte3
Yottabyte3
Mesajlar: 28431
Kayıt: 14 Mar 2006, 02:33
cinsiyet: Erkek

Re: Excell çoklu seçilen satılar nasıl hata almadan nasıl ko

Mesaj gönderen velociraptor » 21 May 2011, 16:15

macro olarak calismiyorlarmi ?
https://www.sordum.net/?p=4019
Knowledge determines destiny, And ye shall know the Truth and the Truth shall make you free

Kullanıcı avatarı
lord_leo
Megabyte2
Megabyte2
Mesajlar: 1124
Kayıt: 25 Nis 2010, 08:39
cinsiyet: Erkek
Konum: internet
İletişim:

Re: Excell çoklu seçilen satılar nasıl hata almadan nasıl ko

Mesaj gönderen lord_leo » 21 May 2011, 18:01

bu uzun gibi
sanki başka çözümlerde vardı ama makro yazmak en kolayı
tabi sürekli yapılıyorsa yoksa tek sefer için uğraştırıcı ama öğrenmek için yapılabilir
teşekküreler
Ben Giderim, Tadım Kalır...

Cevapla