Just nu i M3-nätverket
Gå till innehåll

Kopiera kolumn till nytt blad VBA


TheCaper

Rekommendera Poster

Hej,

 

Har skapat ett Makro med hjälp av internet.

 

Det ser ut så här:

Sub Compare2WorkSheets(ws1 As Worksheet, ws2 As Worksheet)
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Set report = Workbooks.Add
   
With ws1.UsedRange
    ws1row = .Rows.Count
    ws1col = .Columns.Count
End With
With ws2.UsedRange
    ws2row = .Rows.Count
    ws2col = .Columns.Count
End With
   
maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
difference = 0
For col = 1 To maxcol
   
    For row = 1 To maxrow
    colval1 = ""
    colval2 = ""
    colval1 = ws1.Cells(row, col).Formula
    colval2 = ws2.Cells(row, col).Formula
   
    If colval1 <> colval2 Then
    difference = difference + 1
    Cells(row, col).Formula = colval1 & " " & colval2
    Cells(row, col).Interior.Color = 255
    Cells(row, col).Font.ColorIndex = 2
    Cells(row, col).Font.Bold = True
    End If
Next row
Next col
Columns("A:R").ColumnWidth = 25
report.Saved = True
If difference = 0 Then
report.Close False
End If
Set report = Nothing
MsgBox difference & " Celler innehåller olika data! ", vbInformation, " Compare 2 work sheets"

End Sub

Makrot jämför 2 st blad med varandra. Skapar upp ett nytt blad och visar olikheterna i det nya bladet.

Det jag skulle vilja ha med är artikelnumret från kolumn C till det nya bladet.

 

Överkurs är att även plocka bort alla rader där det inte har skett några förändringar.

Länk till kommentar
Dela på andra webbplatser

För att få över kolumn C...

mmh

du stegar över kolumner och sedan över rad.

Och någonstans vill du där kopiera över kolumn C till någon kolumn på (något blad) som Cells refererar till (adressera bättre!)

Undras om inte enklaste blir

If colval1 <> colval2 Then
     If Cells(row, maxCol+1) ="" Then
           Cells(row, maxCol+1).Value = Ws.cells(row, 4).Value
     End If
  ....

Dvs kolla om rad kopierad, gör inget då, annars kopiera.

Hoppa rader utan skillnad? Då får du skapa en till variabel som stegar upp raderna på bladet du kopierar på, bara räkna upp den när en skillnad finns, när något ska kopieras.

 

Det är mina tankar utan att kunna provköra koden.

Länk till kommentar
Dela på andra webbplatser

För att få över kolumn C...

mmh

du stegar över kolumner och sedan över rad.

Och någonstans vill du där kopiera över kolumn C till någon kolumn på (något blad) som Cells refererar till (adressera bättre!)

Undras om inte enklaste blir

If colval1 <> colval2 Then
     If Cells(row, maxCol+1) ="" Then
           Cells(row, maxCol+1).Value = Ws.cells(row, 4).Value
     End If
  ....

Dvs kolla om rad kopierad, gör inget då, annars kopiera.

Hoppa rader utan skillnad? Då får du skapa en till variabel som stegar upp raderna på bladet du kopierar på, bara räkna upp den när en skillnad finns, när något ska kopieras.

 

Det är mina tankar utan att kunna provköra koden.

 

Försökt att lägga upp filen jag arbetar med, men har inte tillstånd till att bifoga denna sortens fil :(

Så bifogar det önskade resultatet för att det ska bli enklare att förstå vad jag är ute efter. 

Länk till kommentar
Dela på andra webbplatser

Makroaktiverade ark kan du lägga upp om du zippar dem först. Eller som du nu gjort, spara som XLS-fil med makron kvar.

 

men tar titt på det (pinga mig om jag glömmer) en dag då min hjärna är piggare.

Länk till kommentar
Dela på andra webbplatser

Du  kanske gett upp hoppet om svar?

En lite julklapp till dig då.

 

Här får du lite kod som ger dig det du önskar.

Sub Compare2WorkSheets(ws1 As Worksheet, ws2 As Worksheet)
    Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
    Dim maxrow As Long, maxCol As Integer, colval1 As String, colval2 As String
    Dim report As Workbook, difference As Long
    Dim row As Long, col As Integer
    
    Dim rwIndex As Integer
    Dim i As Integer
 
    Dim wsTarget As Worksheet
    
    'Set report = Workbooks.Add
    Set wsTarget = ThisWorkbook.Worksheets.Add
    With ws1.UsedRange
        ws1row = .Rows.Count
        ws1col = .Columns.Count
    End With
    With ws2.UsedRange
        ws2row = .Rows.Count
        ws2col = .Columns.Count
    End With
       
    maxrow = ws1row
    maxCol = ws1col
    If maxrow < ws2row Then maxrow = ws2row
    If maxCol < ws2col Then maxCol = ws2col
    difference = 0
   
    rwIndex = 2
    With wsTarget
        For row = 1 To maxrow
            If HasChanged(ws1.Cells(row, 1).Resize(1, maxCol), ws2.Cells(row, 1).Resize(1, maxCol)) Then
                For col = 1 To maxCol
                    If (ws1.Cells(row, col).Formula <> ws2.Cells(row, col).Formula) Then
                        .Cells(rwIndex, col).Formula = ws1.Cells(row, col).Formula & " Nytt värde " & ws2.Cells(row, col).Formula
                        .Cells(rwIndex, col).Interior.Color = 255
                        .Cells(rwIndex, col).Font.ColorIndex = 2
                        .Cells(rwIndex, col).Font.Bold = True
                        difference = difference + 1
                    Else
                        .Cells(rwIndex, col) = ws1.Cells(row, col)
                    End If
                Next col
                rwIndex = rwIndex + 1
            End If
        Next row
        If difference > 0 Then
           .Columns("A:R").ColumnWidth = 25
           ws1.Cells(1, 1).Resize(1, maxCol).Copy .Cells(1, 1)
        End If
        
        
     End With

  '  report.Saved = True
  '  If difference = 0 Then
  '  report.Close False
  '  End If
  '  Set report = Nothing
    MsgBox difference & " Celler innehåller olika data! ", vbInformation, " Compare 2 work sheets"

End Sub


Function HasChanged(rn1 As Range, rn2 As Range) As Boolean
    Dim i As Integer
    For i = 1 To rn1.Columns.Count
        If rn1.Cells(1, i).Formula <> rn2.Cells(1, i).Formula Then
            HasChanged = True
            Exit Function
        End If
    Next i
    HasChanged = False
    
End Function

Alla aktioner håller sig ovan inom en bok, lägger till ett nytt blad där data sparas istället för i en ny bok.

 

Länk till kommentar
Dela på andra webbplatser

Helt fantastiskt! Bästa julklappen iår måste jag säga! Det fungerar exakt så som jag vill ha det. Ett jättetack till dig!

Länk till kommentar
Dela på andra webbplatser

Arkiverat

Det här ämnet är nu arkiverat och är stängt för ytterligare svar.



×
×
  • Skapa nytt...