Extract Data Based On The Same of Header From Multiple Sheet Into One Sheet

[muhammad susanto]

hi all..
i have several sheets (sheet a, sheet b, sheet c. etc...) in one file ..i want extract data only cell B4,B5,B6,H42,H43 and H44 into one sheet based on the same name header....
this my layout :

Excel 2007
	A	B	C	D	E	F	G	H
1	LAND OF REPORT
2	JAYA CORPORATE
3
4	Name of	Bulding A
5	Code of	XXXX
6	Address of	Samara Street 2, Jkt
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42	Land of Meters							Rp50
43	Total Value							Rp99.500
44	Round value							Rp100.000
a

Cell Formulas
Range	Formula
H44	=ROUND(H43,-3)

expected result :

Excel 2007
	A	B	C	D	E	F
1	Name of	Code of	Address of	Land of Meters	Total Value	Round value
2	Bulding A	XXXX	Samara Street 2, Jkt	50	99.500	100.000
3	Bulding B	YYYY	etc
master

someone would help me out this problem ..

m.susanto

 

[mumps]

Try:

Sub CopyRanges()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Master" Then
            ws.Range("B4:B6").Copy
            Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
            ws.Range("H42:H44").Copy
            Sheets("Master").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[muhammad susanto]

Try:

Sub CopyRanges()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Master" Then
            ws.Range("B4:B6").Copy
            Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
            ws.Range("H42:H44").Copy
            Sheets("Master").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

hi Mumps....working great!!
Thank you a lot....

 

[mumps]

My pleasure.

 

[muhammad susanto]

Try:

Sub CopyRanges()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Master" Then
            ws.Range("B4:B6").Copy
            Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
            ws.Range("H42:H44").Copy
            Sheets("Master").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

hi mumps....
for fields Land of Meters, Total Value, Round value (contains formula) the result is #Value !....
how to make the result is value...

 

[mumps]

Are you saying you want to paste the value but not the formula?

 

[muhammad susanto]

yes...my data is contains formula..
i want the result is value...

 

[mumps]

Try:

Sub CopyRanges()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Master" Then
            ws.Range("B4:B6").Copy
            Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
            ws.Range("H42:H44").Copy
            Sheets("Master").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Just a suggestion for you ... when you respond to a post, you don't necessarily have to include a copy of the previous response.

 

[muhammad susanto]

Try:

Sub CopyRanges()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.Name <> "Master" Then
            ws.Range("B4:B6").Copy
            Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
            ws.Range("H42:H44").Copy
            Sheets("Master").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, Transpose:=True
        End If
    Next ws
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Just a suggestion for you ... when you respond to a post, you don't necessarily have to include a copy of the previous response.

thank you mumps..works.!!
you're really great man....

 

[mumps]

You are very welcome.