-1
\$\begingroup\$

The code below does what I need it too but it is ugly and clunky. If I could set the list of cells I want to retreive data from as an array that is declared somewhere, then I could loop through that array rather than declaring each individual cell.

As you can see below, I have had to declare each of the cells I want informatino from at the end of the ThisWorkbook lines. Except for the For Count loop where there are 13 cells in a column that I need information from.

Does anyone know how I could do this?

Sub InfoExtract()

Dim xPath As String
Dim xWb As Workbook
Dim xWs As Worksheet
Dim file As String

Dim i As Integer, j As Integer, k As Integer

xPath = "T:\PROJECTS\***\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False


file = Dir(xPath)
i = 1
Do While file <> ""
    i = i + 1
    j = 3
    Cells(i, 2) = file

    Workbooks.Open (xPath & file)
    Set xWb = ActiveWorkbook

    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(7, 4).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(8, 4).Value
    j = j + 1

    k = 11
    For Count = 1 To 13
        ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(k, 5).Value
        j = j + 1
        k = k + 1
    Next Count

    'Captures the comments
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(24, 4).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(25, 3).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(26, 3).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(27, 3).Value
    j = j + 1

    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(28, 4).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(29, 3).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(30, 3).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(31, 3).Value
    j = j + 1

    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(32, 4).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(33, 3).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(34, 3).Value
    j = j + 1
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(35, 3).Value
    j = j + 1

    xWb.Close
    file = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
\$\endgroup\$

closed as off-topic by πάντα ῥεῖ, Mathieu Guindon, Toby Speight, esote, Mast Apr 10 at 6:38

This question appears to be off-topic. The users who voted to close gave this specific reason:

  • "Code not implemented or not working as intended: Code Review is a community where programmers peer-review your working code to address issues such as security, maintainability, performance, and scalability. We require that the code be working correctly, to the best of the author's knowledge, before proceeding with a review." – πάντα ῥεῖ, Mathieu Guindon, esote
If this question can be reworded to fit the rules in the help center, please edit the question.

  • 1
    \$\begingroup\$ Welcome to CR! As it stands, your post reads like your code doesn't do exactly what it needs to be doing, which means it's probably too early to get your code peer reviewed - reviewers point out edge case bugs, readability, maintainability, extensibility issues and yes, better ways to do things -- but reviewers don't help with implementing the required functionality. Please edit your post to clarify, or come back later with the working code to get feedback on any/all aspects of the code. Cheers! \$\endgroup\$ – Mathieu Guindon Apr 4 at 17:54
  • 1
    \$\begingroup\$ Welcome to Code Review! The site standard is for the title to simply state the task accomplished by the code. Please see How to Ask for examples, and revise the title accordingly. \$\endgroup\$ – Toby Speight Apr 4 at 18:17
  • \$\begingroup\$ @MathieuGuindon Thanks Mathieu. I was told by those over at Stack Overflow that I should post my question here as they thought it was more like a code review issue. Thanks \$\endgroup\$ – Alex H Apr 5 at 10:36
0
\$\begingroup\$

The simple things:

I'm assuming you don't have Option Explicit turned on. That's found in the menu under Tools>Code Settings>Require Variable Declaration. Turn that on it will add Option Explicit to the top of any new code modules, you'll need to retroactively add it to any existing modules. Once you've done that from the menu open Debug>Compile {ProjectName} and you'll be alerted to the fact that your variable Count isn't declared anywhere. A prime example of why it's best to turn it on.

Any sub that doesn't have an access modifier is implicitly Public. Add that to your code Public Sub InfoExtract() to explicitly show you do want it to be public.

Your Do ... Loop is using "" which is better replaced with vbNullString. This lets you know that your code is intentionally using a string without any contents instead of "Foo" where Foo was removed but the string quotes weren't.

I personally find having variables declared just before their use, rather than at the top, makes my code more readable. You have xWS declared but it's never used in your code... This is an example of why a wall of variable declarations at the top makes it easy to miss an unused variable.

Your variable names can be improved. Intead of xPath, xWB and xWS try externalPath, externalWorkbook, and externalWorksheet. i, j, and k don't tell you what they're used for. i --> populationRow, j --> populationColumn makes your code more descriptive as to what it's doing. Converting ThisWorkbook.Worksheets(2) to a descriptive variable name like destinationSheet will make your code more maintainable.

Usage of Cells(7, 4).Value is implicitly using the Activesheet. This can introduce unintended bugs without realizing it. If you do indeed want to use the Activesheet then qualify with Activesheet.Cells() avoiding any ambiguity. At the point in your code where you open a new workbook you can reference it with a variable externalWorksheet like so Set externalWorksheet = externalWorkbook.ActiveSheet. Now when populating destinationSheet.Cells(populationRow, populationColumn).Value = externalWorksheet.Cells(7, 4).Value you have fully qualified references doing just what they say they're doing.


Not so simple things:

Your use of the For ... Next statement is essentially transposing a single column vertical range of cells into a single row.

k = 11
Dim count As Long
For count = 1 To 13
    ThisWorkbook.Worksheets(2).Cells(i, j).Value = Cells(k, 5).Value
    j = j + 1
    k = k + 1
Next count

Range.PasteSpecial takes care of that as shown below.

Dim transposeSourceArea As Range
Set transposeSourceArea = externalWorksheet.Cells(11, 5).Resize(RowSize:=13)
transposeSourceArea.Copy

Dim transposeDestinationArea As Range
Set transposeDestinationArea = destinationSheet.Cells(populationRow, populationColumn + 2).Resize(ColumnSize:=transposeSourceArea.Rows.count)
transposeDestinationArea.PasteSpecial XlPasteType.xlPasteValues, Transpose:=True

Your use of a comment "Captures the comments" is an indication that a dedicated sub is hiding right in front of you. Create a sub that describes what it's doing and has descriptive parameters.

Private Sub CaptureComments(ByVal sourceSheet As Worksheet, ByVal populationSheet As Worksheet, ByVal inputRow As Long, ByVal inputColumn As Long)

Use that function by providing it arguments when you call it CaptureComments destinationSheet, externalWorksheet, populationRow, populationColumn + 15 Within the body of the Sub procedure you can copy all of your code and begin to update it. Your original code is populating a cell then incrementing j. Instead of incrementing it after every cell population change it to be something like below and you'll see that you want it to span across a column.

populationSheet.Cells(i, j).Value = ...
populationSheet.Cells(i, j + 1).Value = ...
...
populationSheet.Cells(i, j + 11).Value = ...

Since population is in a contiguous range you can use an array to do this. You'll need to pull the source values from their cells to populate the array. The static values of 3 and 4 are replaced with constants for maintainability. You'll need to come up with a descriptive name for them.

Const thirdColumn As Long = 3
Const fourthColumn As Long = 4

Dim comments(0 To 11) As String
comments(0) = sourceSheet.Cells(24, fourthColumn).Value
comments(1) = sourceSheet.Cells(25, thirdColumn).Value
...
comments(11) = ...

The final population is done via populationSheet.Cells(inputRow, inputColumn).Resize(ColumnSize:=UBound(comments) - LBound(comments) + 1).Value = comments


Putting everything together. I may have missed a number or two but this should give you an idea. There's likely a better way to deal with the varying rows/columns in CaptureComments using a named range or three but without seeing the data I can only guess what they'd be called.

Public Sub InfoExtract()
    Dim externalPath As String
    externalPath = "T:\PROJECTS\***\"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim file As String
    file = Dir(externalPath)
    Dim populationRow As Long
    populationRow = 2
    Do While file <> vbNullString
        Const populationColumn As Long = 3
        ActiveSheet.Cells(populationRow, 2).Value2 = file

        Workbooks.Open (externalPath & file)
        Dim externalWorkbook As Workbook
        Set externalWorkbook = ActiveWorkbook

        Dim externalWorksheet As Worksheet
        Set externalWorksheet = externalWorkbook.ActiveSheet

        Dim destinationSheet As Worksheet
        Set destinationSheet = ThisWorkbook.Worksheets(2)

        destinationSheet.Cells(populationRow, populationColumn).Value = externalWorksheet.Cells(7, 4).Value
        destinationSheet.Cells(populationRow, populationColumn + 1).Value = externalWorksheet.Cells(8, 4).Value

        Dim transposeSourceArea As Range
        Set transposeSourceArea = externalWorksheet.Cells(11, 5).Resize(RowSize:=13)
        transposeSourceArea.Copy

        Dim transposeDestinationArea As Range
        Set transposeDestinationArea = destinationSheet.Cells(populationRow, populationColumn + 2).Resize(ColumnSize:=transposeSourceArea.Rows.count)
        transposeDestinationArea.PasteSpecial XlPasteType.xlPasteValues, Transpose:=True

        CaptureComments destinationSheet, externalWorksheet, populationRow, populationColumn + 15

        externalWorkbook.Close
        file = Dir

        populationRow = populationRow + 1
    Loop

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Private Sub CaptureComments(ByVal sourceSheet As Worksheet, _
                            ByVal populationSheet As Worksheet, _
                            ByVal inputRow As Long, _
                            ByVal inputColumn As Long)
    Const thirdColumn As Long = 3
    Const fourthColumn As Long = 4

    Dim comments(0 To 11) As String
    comments(0) = sourceSheet.Cells(24, fourthColumn).Value
    comments(1) = sourceSheet.Cells(25, thirdColumn).Value
    comments(2) = sourceSheet.Cells(26, thirdColumn).Value
    comments(3) = sourceSheet.Cells(27, thirdColumn).Value

    comments(4) = sourceSheet.Cells(28, fourthColumn).Value
    comments(5) = sourceSheet.Cells(29, thirdColumn).Value
    comments(6) = sourceSheet.Cells(30, thirdColumn).Value
    comments(7) = sourceSheet.Cells(31, thirdColumn).Value

    comments(8) = sourceSheet.Cells(32, fourthColumn).Value
    comments(9) = sourceSheet.Cells(33, thirdColumn).Value
    comments(10) = sourceSheet.Cells(34, thirdColumn).Value
    comments(11) = sourceSheet.Cells(35, thirdColumn).Value

    populationSheet.Cells(inputRow, inputColumn).Resize(ColumnSize:=UBound(comments) - LBound(comments) + 1).Value = comments
End Sub
\$\endgroup\$

Not the answer you're looking for? Browse other questions tagged or ask your own question.