Hi everyone! I'm new in this community and I'm very glad to form part of it. First of all, I consider I am an intermediate user of VBA so I have a certain level of skill working with it. However, I am in trouble with this work I have to do because I don't get to accomplish my goal of running it.
First I will explain what my purpose is about.
I have a lot of workbooks, each with a code as a name, for example, one workbook is "2014T1AH54". where "2014" is the year "T1" is the first trimester (this could be T2 T3 or T4), "AH" is something that is not going to change and "54" represents a number which will vary from 1 to 180.
This workbooks have only one sheet (sheet 1) and each one contains information in tables which I have to extract of and place it in my workbook called "registro".
I have already achieved to extract the information from one workbook. However I get trouble when I have to extract of all these workbooks at the same time. The point is that the information in the table of each workbook must be placed if the table of my workbook "registro" is empty. In other words, I have to paste the content of the table going down. For example, once I copied the information of the table of 2014T1AH54 in the workbook registro table, then the next line of it will serve as the first place to enter the other table information of the workbook called 2014T2AH54, then going down I will copy the information of 2014T3AH54 and so on. I have my code here and this is:
Function FileOrDirExists(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file
' or folder exists, false if not.
'PathName : Supports Windows mapped drives or UNC
' : Supports Macintosh paths
'File usage : Provide full file path and extension
'Folder usage : Provide full folder path
' Accepts with/without trailing "\" (Windows)
' Accepts with/without trailing ":" (Macintosh)
Dim iTemp As Integer
'Ignore errors to allow for error evaluation
On Error Resume Next
iTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
'Resume error checking
On Error GoTo 0
End Function
Sub macro1()
Dim t, cod As Integer
Dim xruta As String
Dim directory As String
Dim i As Integer
Dim dato1 As String
Dim range_dir As Range
Dim range_registro As Range
Dim wbk1, wbk2 As Workbook
xruta = ActiveWorkbook.Path
For t = 1 To 4
For cod = 1 To 180
directory = xruta & "\" & "2014T" & t & "AH" & cod & ".xls"
registro1 = xruta & "\" & "registro" & ".xlsx"
If FileOrDirExists(directory) = True Then
Set wbk1 = Workbooks.Open(directory).Sheets(1)
For i = 1 To 11
if Cells(i, 3).Value <> "" then
Call wbk1.Rows(CStr(i) & ":" & CStr(i + 100)).Copy
ThisWorkbook.Sheets(1).Range("a5").select
While ActiveCell.Offset(0, 2) <> ""
ActiveCell.Offset(0, -2).Select
With Selection
.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End With
Wend
end if
Next
End If
Next
Next
End Sub
What is highlighted with red color is the one that doesn't work. It doesn't work with select or activate and I don't know why. I don't get to run the program because I can't activate the range and proceed to find if activecell.offset(0,2) is empty. Because if this cell is full, then this means there is the information of the last workbook copied (for example: the information of 2014T2AH54). I can't copy if this cell or range is fulled, because, as well as I said, I want to copy all the information going down without loosing any info.
I hope I could be explicit in my purpose and hope answers please,
just in case, I have an example attached of for example, also I have the workbook called "datos2" where the code is located and I have the workbook called "2014T2AH54" where which I have to extract this information!
thank you very much in advance,
Jos
Bookmarks