How to Copy data from one sheet to another

[jeevaaustin]

Hello Guru's,

I am new to this form and VB macro i need help ..

I get a file where i have some data , its as below if the total dr is not equal to cr then i want the data to be copied to a new sheet ...how can i create a macro for this ?

Line	Account	Desc	dr	cr	dr	cr
1	123	test1	10	0	12	0
2	345	test2	12	0	14	0
				total	26	0
Line	Account	Desc	dr	cr	dr	cr
1	123	test1	10	0	12	0
2	345	test2	12	0		14
4	9393	test3	15	0	15	0
				total	27	14
Line	Account	Desc	dr	cr	dr	cr
1	345	test8	10	0	14	0
2	234	test1	12	0		14
				total	14	14

<tbody>
</tbody>

result i am looking for :

Line	Account	Desc	dr	cr	dr	cr
1	123	test1	10	0	12	0
2	345	test2	12	0	14	0
				total	26	0
Line	Account	Desc	dr	cr	dr	cr
1	123	test1	10	0	12	0
2	345	test2	12	0		14
4	9393	test3	15	0	15	0
				total	27	14

<tbody>
</tbody>

 

[patel45]

Sub rangecopy()
With Sheets(1)
  LR = .Cells(.Rows.Count, "E").End(xlUp).Row
  drow = 1
  r1 = 2
  Application.ScreenUpdating = False
  For j = 1 To LR
    If .Range("A" & j) = "Line" Then
      r1 = j
    ElseIf .Range("E" & j) = "total" Then
      r2 = j
      If .Range("F" & j) <> .Range("G" & j) Then
        .Range("A" & r1 & ":G" & r2).Copy Sheets(2).Range("A" & drow)
        drow = drow + r2 - r1 + 1
      End If
    End If
  Next
End With
Application.ScreenUpdating = True

End Sub

 

[jeevaaustin]

Sub rangecopy()
With Sheets(1)
  LR = .Cells(.Rows.Count, "E").End(xlUp).Row
  drow = 1
  r1 = 2
  Application.ScreenUpdating = False
  For j = 1 To LR
    If .Range("A" & j) = "Line" Then
      r1 = j
    ElseIf .Range("E" & j) = "total" Then
      r2 = j
      If .Range("F" & j) <> .Range("G" & j) Then
        .Range("A" & r1 & ":G" & r2).Copy Sheets(2).Range("A" & drow)
        drow = drow + r2 - r1 + 1
      End If
    End If
  Next
End With
Application.ScreenUpdating = True

End Sub

Thanks Patel45 ..it worked ..

 

[HaHoBe]

Hi, jeevaaustin,

although this has been solved I like to show a different approach basicly based on the code patel45 posted (which may seem much more complicated as it uses constants opposite to hard coded ranges). Another difference is that I compsre the criteria in uppercase:

Sub MR_Excel_711476()

Dim lngStart          As Long                 'StartRow for a subset of data
Dim lngEnd            As Long                 'EndRow for this subset
Dim lngCounter        As Long                 'counter to loop through the rows
Dim lngCopyRow        As Long                 'first free row on target sheet

Const cstrSHEET_FROM  As String = "Sheet1"    'sheet from which to copy
Const cstrSHEET_To    As String = "Sheet2"    'target sheet

Const cstrCOL_LINE    As String = "A"         'column in which the new subset begins
Const cstrCOL_TOTAL   As String = "E"         'column in which the subset ends

Const cstrCOL_CR      As String = "F"         'first column with data to compare
Const cstrCOL_DR      As String = "G"         'second column with data to compare

Const cstrSTART       As String = "Line"      'item which will define start of subset
Const cstrEND         As String = "total"     'item which will define end of subset

Application.ScreenUpdating = False

With Worksheets(cstrSHEET_FROM)
  For lngCounter = 1 To .Cells(.Rows.Count, cstrCOL_TOTAL).End(xlUp).Row
    If UCase(.Range(cstrCOL_LINE & lngCounter)) = UCase(cstrSTART) Then
      lngStart = lngCounter
    ElseIf UCase(.Range(cstrCOL_TOTAL & lngCounter)) = UCase(cstrEND) Then
      lngEnd = lngCounter
      If .Range(cstrCOL_CR & lngCounter) <> .Range(cstrCOL_DR & lngCounter) Then
        lngCopyRow = Worksheets(cstrSHEET_To).Cells(.Rows.Count, cstrCOL_TOTAL).End(xlUp).Row + 1
        Worksheets(cstrSHEET_To).Range(cstrCOL_LINE & lngCopyRow & ":" & cstrCOL_DR & lngCopyRow + lngEnd - lngStart + 1).Value = _
            .Range(cstrCOL_LINE & lngStart & ":" & cstrCOL_DR & lngEnd - lngStart + 1).Value
      End If
    End If
  Next lngCounter
End With

Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[jeevaaustin]

Hi, jeevaaustin,

although this has been solved I like to show a different approach basicly based on the code patel45 posted (which may seem much more complicated as it uses constants opposite to hard coded ranges). Another difference is that I compsre the criteria in uppercase:

Sub MR_Excel_711476()

Dim lngStart          As Long                 'StartRow for a subset of data
Dim lngEnd            As Long                 'EndRow for this subset
Dim lngCounter        As Long                 'counter to loop through the rows
Dim lngCopyRow        As Long                 'first free row on target sheet

Const cstrSHEET_FROM  As String = "Sheet1"    'sheet from which to copy
Const cstrSHEET_To    As String = "Sheet2"    'target sheet

Const cstrCOL_LINE    As String = "A"         'column in which the new subset begins
Const cstrCOL_TOTAL   As String = "E"         'column in which the subset ends

Const cstrCOL_CR      As String = "F"         'first column with data to compare
Const cstrCOL_DR      As String = "G"         'second column with data to compare

Const cstrSTART       As String = "Line"      'item which will define start of subset
Const cstrEND         As String = "total"     'item which will define end of subset

Application.ScreenUpdating = False

With Worksheets(cstrSHEET_FROM)
  For lngCounter = 1 To .Cells(.Rows.Count, cstrCOL_TOTAL).End(xlUp).Row
    If UCase(.Range(cstrCOL_LINE & lngCounter)) = UCase(cstrSTART) Then
      lngStart = lngCounter
    ElseIf UCase(.Range(cstrCOL_TOTAL & lngCounter)) = UCase(cstrEND) Then
      lngEnd = lngCounter
      If .Range(cstrCOL_CR & lngCounter) <> .Range(cstrCOL_DR & lngCounter) Then
        lngCopyRow = Worksheets(cstrSHEET_To).Cells(.Rows.Count, cstrCOL_TOTAL).End(xlUp).Row + 1
        Worksheets(cstrSHEET_To).Range(cstrCOL_LINE & lngCopyRow & ":" & cstrCOL_DR & lngCopyRow + lngEnd - lngStart + 1).Value = _
            .Range(cstrCOL_LINE & lngStart & ":" & cstrCOL_DR & lngEnd - lngStart + 1).Value
      End If
    End If
  Next lngCounter
End With

Application.ScreenUpdating = True

End Sub

Ciao,
Holger

Thanks Holger...