Macro to copy data under matching column header

I am trying to write a macro to copy data from multiple spreadsheets and get the data to paste into the proper matching headers. Here is what I have so far. It copies over, but then all of the data disappears except what was copied into the first column.

Sub Macro2()

Dim wks As Worksheet
Dim varValue1 As String
Dim varFind1 As Integer
Dim varCount1 As Integer
Dim varCount2 As Integer
Dim varRow As Integer
Dim varCol As Integer
Dim varColMark As Integer
Dim z As Integer
z = 2


For Each wks In Worksheets
If Left(wks.Name, 2) = "AL" Then
Else
GoTo skip1
End If
varCount1 = wks.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
varCount2 = wks.Range("4:4").Cells.SpecialCells(xlCellTypeConstants).Count
For varCol = 1 To varCount2
For x = 1 To 27
If Worksheets("data").Cells(1, x).Value = wks.Cells(4, varCol).Value Then
varColMark = x
'Debug.Print varColMark, Worksheets("data").Cells(1, x).Value

End If
'Debug.Print wks.Cells(4, varCol).Value
Next x
For varRow = 4 To varCount1 + 3
If varCol = 1 Then
Worksheets("data").Cells(z, varColMark).Value = wks.Cells(varRow + 4, varCol)
'Debug.Print wks.Cells(varRow + 4, varCol)

z = z + 1
Else
For h = z - varCount1 To z
Worksheets("data").Cells(h, varColMark).Value = wks.Cells(varRow + 4, varCol)
Next h
End If

'Debug.Print wks.Name; " "; z; " "; " "; varRow; " "; varCol; " - "; wks.Cells(varRow + 4, varCol)



Next varRow




Next varCol

skip1:
Next wks

End Sub
Sub FindRightColumn()

Dim varValue1 As String

Dim varFind1 As Integer
'Worksheets("AL-JJ-enrollment-2009").Cells(i + 4, 1)
varValue1 = Worksheets("AL-JJ-enrollment-2009").Cells(4, 16)
'Debug.Print varValue1
For x = 1 To 27
If Worksheets("data").Cells(1, x).Value = varValue1 Then
MsgBox x

End If


Next x



End Sub